diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 02e7d50969c72f4669658206a59ef7ec3991d546..cc4a4241d5405fa7d3dcbeeef8b7efddb216d222 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 21224ebc45c843d2f79231bb80f72028d5f1c278..516cf0e5862ac5ec7bce0d8870c34d629b8c6ed4 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 85c5d07882627166a11eea0a256798b75b5cfba2..34f3298b0d3b66b7f68c36f04b4bf9917e49a04b 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 0000000000000000000000000000000000000000..206675e5e2b11563921a545547c28698ad7b71c6
--- /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 2738929aa5313b94a05329e48be651b197a150f9..5bef07f369c3610935b448b127d429e123eb315f 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 $
diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst
index bb31b0783a0699309438b6708375046c26c28fde..7ed258a090f83a2f806069a253350ed83cd5bec3 100644
--- a/docs/users_guide/extending_ghc.rst
+++ b/docs/users_guide/extending_ghc.rst
@@ -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
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
+ }
+
+ parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
+ parsedPlugin _ _ pm
+ = do liftIO $ putStrLn $ "parsePlugin: \n" ++ (showSDocUnsafe $ ppr $ hpm_module pm)
+ return pm
+
+ renamedAction :: [CommandLineOption] -> ModSummary
+ -> ( HsGroup GhcRn, [LImportDecl GhcRn]
+ , Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString )
+ -> Hsc ()
+ renamedAction _ _ ( gr, _, _, _ )
+ = liftIO $ putStrLn "typeCheckPlugin (rn): " ++ (showSDocUnsafe $ ppr gr)
+
+ typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> Hsc TcGblEnv
+ typecheckPlugin _ _ tc
+ = do liftIO $ putStrLn $ "typeCheckPlugin (rn): \n" ++ (showSDocUnsafe $ ppr $ tcg_rn_decls tc)
+ liftIO $ putStrLn $ "typeCheckPlugin (tc): \n" ++ (showSDocUnsafe $ ppr $ tcg_binds tc)
+ return tc
+
+ metaPlugin :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
+ metaPlugin _ meta
+ = do liftIO $ putStrLn $ "meta: " ++ (showSDocUnsafe $ ppr meta)
+ return meta
+
+ interfaceLoadPlugin :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
+ interfaceLoadPlugin _ iface
+ = do liftIO $ putStrLn $ "interface loaded: " ++ (showSDocUnsafe $ ppr $ mi_module iface)
+ return iface
+
+When you compile a simple module that contains Template Haskell splice
+
+::
+
+ {-# LANGUAGE TemplateHaskell #-}
+ module A where
+
+ a = ()
+
+ $(return [])
+
+with the compiler flags ``-fplugin SourcePlugin`` it will give the following
+output:
+
+.. code-block:: none
+
+ parsePlugin:
+ module A where
+ a = ()
+ $(return [])
+ interface loaded: Prelude
+ interface loaded: GHC.Float
+ interface loaded: GHC.Base
+ interface loaded: Language.Haskell.TH.Lib.Internal
+ interface loaded: Language.Haskell.TH.Syntax
+ interface loaded: GHC.Types
+ meta: return []
+ interface loaded: GHC.Integer.Type
+ typeCheckPlugin (rn):
+ Just a = ()
+ typeCheckPlugin (tc):
+ {$trModule = Module (TrNameS "main"#) (TrNameS "A"#), a = ()}
+
+
.. _plugin_recompilation:
Controlling Recompilation
diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile
index 3e983fded6dbf1ff02edd070e265366cbd205975..6c823cc5d521e628953d5e68acffb9f713fee3ec 100644
--- a/testsuite/tests/plugins/Makefile
+++ b/testsuite/tests/plugins/Makefile
@@ -21,6 +21,34 @@ plugins08:
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins08.hs -package-db simple-plugin/pkg.plugins08/local.package.conf
./plugins08
+.PHONY: plugins09
+plugins09:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins09.hs -package-db simple-plugin/pkg.plugins09/local.package.conf -fplugin Simple.SourcePlugin -fplugin-opt Simple.SourcePlugin:a -fplugin-opt Simple.SourcePlugin:b -plugin-package simple-plugin
+
+.PHONY: plugins10
+plugins10:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins10.hs QuasiQuotation.hs -package-db simple-plugin/pkg.plugins10/local.package.conf -fplugin Simple.SourcePlugin -plugin-package simple-plugin
+
+.PHONY: plugins11
+plugins11:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins11.hs -package-db simple-plugin/pkg.plugins11/local.package.conf -plugin-package simple-plugin
+
+.PHONY: plugins12
+plugins12:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins12.hs -package-db simple-plugin/pkg.plugins12/local.package.conf -plugin-package simple-plugin
+
+.PHONY: plugins13
+plugins13:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins13.hs PluginFilteredExport.hs -package-db simple-plugin/pkg.plugins13/local.package.conf -plugin-package simple-plugin
+
+.PHONY: plugins14
+plugins14:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins14.hs -package-db simple-plugin/pkg.plugins14/local.package.conf -plugin-package simple-plugin
+
+.PHONY: plugins15
+plugins15:
+ "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins15.hs MetaRemoveHelper.hs -package-db simple-plugin/pkg.plugins15/local.package.conf -plugin-package simple-plugin
+
# -package (should work for backwards compatibility)
.PHONY: T10420
T10420:
diff --git a/testsuite/tests/plugins/MetaRemoveHelper.hs b/testsuite/tests/plugins/MetaRemoveHelper.hs
new file mode 100644
index 0000000000000000000000000000000000000000..06a67995f78ebec25888dd3a754c4ebbb28f8461
--- /dev/null
+++ b/testsuite/tests/plugins/MetaRemoveHelper.hs
@@ -0,0 +1,6 @@
+module MetaRemoveHelper where
+
+import Language.Haskell.TH
+
+clear :: Q [Dec] -> Q [Dec]
+clear _ = return []
diff --git a/testsuite/tests/plugins/PluginFilteredExport.hs b/testsuite/tests/plugins/PluginFilteredExport.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6dd62d33ff8838bfed8aefc09f910b533d0132c9
--- /dev/null
+++ b/testsuite/tests/plugins/PluginFilteredExport.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -fplugin Simple.RemovePlugin #-}
+{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:map #-}
+{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:typecheck #-}
+-- testing that the plugin can alter the parsed representation
+module PluginFilteredExport where
+
+map :: ()
+map = ()
diff --git a/testsuite/tests/plugins/QuasiQuotation.hs b/testsuite/tests/plugins/QuasiQuotation.hs
new file mode 100644
index 0000000000000000000000000000000000000000..b8fe5d6b2629dbf97ab9075d54fa7c30689a38c8
--- /dev/null
+++ b/testsuite/tests/plugins/QuasiQuotation.hs
@@ -0,0 +1,11 @@
+module QuasiQuotation where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Quote
+
+stringify :: QuasiQuoter
+stringify = QuasiQuoter { quoteExp = return . LitE . StringL
+ , quotePat = return . LitP . StringL
+ , quoteType = return . LitT . StrTyLit
+ , quoteDec = const (return [])
+ }
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index 94d0e2d053d12678de718099b04b2b556725633f..34b11623ef15ca67a9db2b49d0104d95dc9ced78 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -39,6 +39,42 @@ test('plugins08',
pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins08 TOP={top}')],
run_command, ['$MAKE -s --no-print-directory plugins08'])
+test('plugins09',
+ [extra_files(['simple-plugin/']),
+ pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins09 TOP={top}')],
+ run_command, ['$MAKE -s --no-print-directory plugins09'])
+
+test('plugins10',
+ [expect_broken(15216),
+ extra_files(['simple-plugin/', 'QuasiQuotation.hs']),
+ pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins10 TOP={top}')],
+ run_command, ['$MAKE -s --no-print-directory plugins10'])
+
+test('plugins11',
+ [extra_files(['simple-plugin/']),
+ pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins11 TOP={top}')],
+ run_command, ['$MAKE -s --no-print-directory plugins11'])
+
+test('plugins12',
+ [extra_files(['simple-plugin/']),
+ pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins12 TOP={top}')],
+ run_command, ['$MAKE -s --no-print-directory plugins12'])
+
+test('plugins13',
+ [extra_files(['simple-plugin/', 'PluginFilteredExport.hs']),
+ pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins13 TOP={top}')],
+ run_command, ['$MAKE -s --no-print-directory plugins13'])
+
+test('plugins14',
+ [extra_files(['simple-plugin/']),
+ pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins14 TOP={top}')],
+ run_command, ['$MAKE -s --no-print-directory plugins14'])
+
+test('plugins15',
+ [extra_files(['simple-plugin/', 'MetaRemoveHelper.hs']),
+ pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins15 TOP={top}')],
+ run_command, ['$MAKE -s --no-print-directory plugins15'])
+
test('T10420',
[extra_files(['rule-defining-plugin/']),
pre_cmd('$MAKE -s --no-print-directory -C rule-defining-plugin package.T10420 TOP={top}')],
diff --git a/testsuite/tests/plugins/plugins04.stderr b/testsuite/tests/plugins/plugins04.stderr
index f0acc67d22e0f64391496c9483de05a5c48021a4..46c0f9ce556a526147e4eeb275790b042328eb13 100644
--- a/testsuite/tests/plugins/plugins04.stderr
+++ b/testsuite/tests/plugins/plugins04.stderr
@@ -1,2 +1,2 @@
Module imports form a cycle:
- module ‘HomePackagePlugin’ (./HomePackagePlugin.hs) imports itself
+ module ‘HomePackagePlugin’ (./HomePackagePlugin.hs) imports itself
\ No newline at end of file
diff --git a/testsuite/tests/plugins/plugins09.hs b/testsuite/tests/plugins/plugins09.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d843c00b78275c5bbdfcde9920a811bb01038a2d
--- /dev/null
+++ b/testsuite/tests/plugins/plugins09.hs
@@ -0,0 +1 @@
+module A where
diff --git a/testsuite/tests/plugins/plugins09.stdout b/testsuite/tests/plugins/plugins09.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..efb740b9ab06bca77e05315eaf6c6e9462c56056
--- /dev/null
+++ b/testsuite/tests/plugins/plugins09.stdout
@@ -0,0 +1,8 @@
+parsePlugin(a,b)
+interfacePlugin: Prelude
+interfacePlugin: GHC.Float
+interfacePlugin: GHC.Base
+interfacePlugin: GHC.Types
+typeCheckPlugin (rn)
+typeCheckPlugin (tc)
+interfacePlugin: GHC.Integer.Type
\ No newline at end of file
diff --git a/testsuite/tests/plugins/plugins10.hs b/testsuite/tests/plugins/plugins10.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d4564a2c292a7df4bb88a4acc74918dfcb9e68df
--- /dev/null
+++ b/testsuite/tests/plugins/plugins10.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -fplugin-opt Simple.SourcePlugin:a #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+module B where
+
+import QuasiQuotation
+
+$(return [])
+
+x = [stringify|x|]
diff --git a/testsuite/tests/plugins/plugins10.stdout b/testsuite/tests/plugins/plugins10.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..737789cc56a198f92a6d552687dfc127761701fb
--- /dev/null
+++ b/testsuite/tests/plugins/plugins10.stdout
@@ -0,0 +1,18 @@
+parsePlugin()
+interfacePlugin: Prelude
+interfacePlugin: Language.Haskell.TH
+interfacePlugin: Language.Haskell.TH.Quote
+interfacePlugin: GHC.Float
+interfacePlugin: GHC.Base
+interfacePlugin: Language.Haskell.TH.Syntax
+interfacePlugin: GHC.Types
+typeCheckPlugin (rn)
+typeCheckPlugin (tc)
+interfacePlugin: GHC.Integer.Type
+parsePlugin(a)
+interfacePlugin: Language.Haskell.TH.Lib.Internal
+metaPlugin: return []
+metaPlugin: quoteExp stringify "x"
+interfacePlugin: GHC.CString
+typeCheckPlugin (rn)
+typeCheckPlugin (tc)
\ No newline at end of file
diff --git a/testsuite/tests/plugins/plugins11.hs b/testsuite/tests/plugins/plugins11.hs
new file mode 100644
index 0000000000000000000000000000000000000000..f714472a07779aae7f83c3eb84c2107bf7b268cf
--- /dev/null
+++ b/testsuite/tests/plugins/plugins11.hs
@@ -0,0 +1,2 @@
+{-# OPTIONS_GHC -fplugin Simple.SourcePlugin #-}
+module A where
diff --git a/testsuite/tests/plugins/plugins11.stdout b/testsuite/tests/plugins/plugins11.stdout
new file mode 100644
index 0000000000000000000000000000000000000000..1e630427c17e5ff2f2d881e3246735bae8747228
--- /dev/null
+++ b/testsuite/tests/plugins/plugins11.stdout
@@ -0,0 +1,8 @@
+parsePlugin()
+interfacePlugin: Prelude
+interfacePlugin: GHC.Float
+interfacePlugin: GHC.Base
+interfacePlugin: GHC.Types
+typeCheckPlugin (rn)
+typeCheckPlugin (tc)
+interfacePlugin: GHC.Integer.Type
\ No newline at end of file
diff --git a/testsuite/tests/plugins/plugins12.hs b/testsuite/tests/plugins/plugins12.hs
new file mode 100644
index 0000000000000000000000000000000000000000..96d35db1791ad650c07eddcd54daf1a9a1464b5d
--- /dev/null
+++ b/testsuite/tests/plugins/plugins12.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -fplugin Simple.RemovePlugin #-}
+{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:map #-}
+{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:parse #-}
+-- testing that the plugin can alter the parsed representation
+module A where
+
+map x = ()
+
+x = map show [1,2,3]
diff --git a/testsuite/tests/plugins/plugins13.hs b/testsuite/tests/plugins/plugins13.hs
new file mode 100644
index 0000000000000000000000000000000000000000..273aba2df94616e07abcbc031d375961ab979b51
--- /dev/null
+++ b/testsuite/tests/plugins/plugins13.hs
@@ -0,0 +1,5 @@
+module A where
+
+import PluginFilteredExport
+
+x = map show [1,2,3]
diff --git a/testsuite/tests/plugins/plugins14.hs b/testsuite/tests/plugins/plugins14.hs
new file mode 100644
index 0000000000000000000000000000000000000000..6f4c2f5780951b554b766a81d7287fa2bee47593
--- /dev/null
+++ b/testsuite/tests/plugins/plugins14.hs
@@ -0,0 +1,11 @@
+{-# OPTIONS_GHC -fplugin Simple.RemovePlugin #-}
+{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:map #-}
+{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:interface #-}
+module A where
+-- test if a definition can be removed from loaded interface
+
+map :: ()
+map = ()
+
+x :: ()
+x = map
diff --git a/testsuite/tests/plugins/plugins15.hs b/testsuite/tests/plugins/plugins15.hs
new file mode 100644
index 0000000000000000000000000000000000000000..be760192ae813d075a18926189d3b31af77d6640
--- /dev/null
+++ b/testsuite/tests/plugins/plugins15.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fplugin Simple.RemovePlugin #-}
+{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:clear #-}
+{-# OPTIONS_GHC -fplugin-opt Simple.RemovePlugin:meta #-}
+{-# LANGUAGE TemplateHaskell #-}
+-- testing that the plugin can alter the evaluated splice
+module A where
+
+import MetaRemoveHelper
+
+$(clear [d| a = () |])
+
+x = a
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
new file mode 100644
index 0000000000000000000000000000000000000000..c64b62f8a7ede8ee29fd1ac6e2c05dcd63378133
--- /dev/null
+++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
+module Simple.RemovePlugin where
+
+import Control.Monad.IO.Class
+import Data.List (intercalate)
+import Plugins
+import Bag
+import HscTypes
+import TcRnTypes
+import HsExtension
+import HsExpr
+import Outputable
+import SrcLoc
+import HsSyn
+import HsBinds
+import OccName
+import RdrName
+import Name
+import Avail
+
+plugin :: Plugin
+plugin = defaultPlugin { parsedResultAction = parsedPlugin
+ , typeCheckResultAction = typecheckPlugin
+ , spliceRunAction = metaPlugin'
+ , interfaceLoadAction = interfaceLoadPlugin'
+ }
+
+parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
+ -> Hsc HsParsedModule
+parsedPlugin [name, "parse"] _ pm
+ = return $ pm { hpm_module = removeParsedBinding name (hpm_module pm) }
+parsedPlugin _ _ pm = return pm
+
+removeParsedBinding :: String -> Located (HsModule GhcPs)
+ -> Located (HsModule GhcPs)
+removeParsedBinding name (L l m)
+ = (L l (m { hsmodDecls = filter (notNamedAs name) (hsmodDecls m) } ))
+ where notNamedAs name (L _ (ValD _ (FunBind { fun_id = L _ fid })))
+ = occNameString (rdrNameOcc fid) /= name
+ notNamedAs _ _ = True
+
+typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> Hsc TcGblEnv
+typecheckPlugin [name, "typecheck"] _ tc
+ = return $ tc { tcg_exports = filter (availNotNamedAs name) (tcg_exports tc)
+ , tcg_binds = filterBag (notNamedAs name) (tcg_binds tc)
+ }
+ where notNamedAs name (L _ FunBind { fun_id = L _ fid })
+ = occNameString (getOccName fid) /= name
+ notNamedAs name (L _ AbsBinds { abs_binds = bnds })
+ = all (notNamedAs name) bnds
+ notNamedAs _ (L _ b) = True
+typecheckPlugin _ _ tc = return tc
+
+metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
+metaPlugin' [name, "meta"] (L _ (HsApp noExt (L l (HsVar _ (L _ id))) e))
+ | occNameString (getOccName id) == name
+ = return e
+metaPlugin' _ meta = return meta
+
+interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
+interfaceLoadPlugin' [name, "interface"] iface
+ = return $ iface { mi_exports = filter (availNotNamedAs name)
+ (mi_exports iface)
+ }
+interfaceLoadPlugin' _ iface = return iface
+
+availNotNamedAs :: String -> AvailInfo -> Bool
+availNotNamedAs name avail
+ = occNameString (getOccName (availName avail)) /= name
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
new file mode 100644
index 0000000000000000000000000000000000000000..d5c9dd1856a83b47586008843fc01d066a97e43e
--- /dev/null
+++ b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
@@ -0,0 +1,52 @@
+module Simple.SourcePlugin where
+
+import Control.Monad.IO.Class
+import Data.List (intercalate)
+import Data.Maybe (isJust)
+import Plugins
+import HscTypes
+import TcRnTypes
+import HsExtension
+import Avail
+import HsExpr
+import Outputable
+import HsImpExp
+import HsDecls
+import HsDoc
+
+plugin :: Plugin
+plugin = defaultPlugin { parsedResultAction = parsedPlugin
+ , typeCheckResultAction = typecheckPlugin
+ , spliceRunAction = metaPlugin'
+ , interfaceLoadAction = interfaceLoadPlugin'
+ , renamedResultAction = Just renamedAction
+ }
+
+parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
+ -> Hsc HsParsedModule
+parsedPlugin opts _ pm
+ = do liftIO $ putStrLn $ "parsePlugin(" ++ intercalate "," opts ++ ")"
+ return pm
+
+renamedAction :: [CommandLineOption] -> ModSummary
+ -> ( HsGroup GhcRn, [LImportDecl GhcRn]
+ , Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString )
+ -> Hsc ()
+renamedAction _ _ ( gr, _, _, _ )
+ = liftIO $ putStrLn "typeCheckPlugin (rn)"
+
+typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> Hsc TcGblEnv
+typecheckPlugin _ _ tc
+ = do liftIO $ putStrLn "typeCheckPlugin (tc)"
+ return tc
+
+metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
+metaPlugin' _ meta
+ = do liftIO $ putStrLn $ "metaPlugin: " ++ (showSDocUnsafe $ ppr meta)
+ return meta
+
+interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
+interfaceLoadPlugin' _ iface
+ = do liftIO $ putStrLn $ "interfacePlugin: "
+ ++ (showSDocUnsafe $ ppr $ mi_module iface)
+ return iface
diff --git a/testsuite/tests/plugins/simple-plugin/simple-plugin.cabal b/testsuite/tests/plugins/simple-plugin/simple-plugin.cabal
index 011ed67e235deb17e0cfa5e107b7d09ea804c133..0a3c49e9882a2baa2eb7181c73c88c121a5e15a3 100644
--- a/testsuite/tests/plugins/simple-plugin/simple-plugin.cabal
+++ b/testsuite/tests/plugins/simple-plugin/simple-plugin.cabal
@@ -17,4 +17,6 @@ Library
Exposed-Modules:
Simple.Plugin
Simple.BadlyTypedPlugin
- Simple.DataStructures
\ No newline at end of file
+ Simple.DataStructures
+ Simple.SourcePlugin
+ Simple.RemovePlugin