Extended the plugin system to run plugins on more representations
authorBoldizsar Nemeth <nboldi@elte.hu>
Sat, 2 Jun 2018 23:08:40 +0000 (19:08 -0400)
committerBen Gamari <ben@smart-cactus.org>
Sun, 3 Jun 2018 03:20:47 +0000 (23:20 -0400)
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

25 files changed:
compiler/iface/LoadIface.hs
compiler/main/HscMain.hs
compiler/main/Plugins.hs
compiler/simplCore/CoreMonad.hs-boot [new file with mode: 0644]
compiler/typecheck/TcSplice.hs
docs/users_guide/extending_ghc.rst
testsuite/tests/plugins/Makefile
testsuite/tests/plugins/MetaRemoveHelper.hs [new file with mode: 0644]
testsuite/tests/plugins/PluginFilteredExport.hs [new file with mode: 0644]
testsuite/tests/plugins/QuasiQuotation.hs [new file with mode: 0644]
testsuite/tests/plugins/all.T
testsuite/tests/plugins/plugins04.stderr
testsuite/tests/plugins/plugins09.hs [new file with mode: 0644]
testsuite/tests/plugins/plugins09.stdout [new file with mode: 0644]
testsuite/tests/plugins/plugins10.hs [new file with mode: 0644]
testsuite/tests/plugins/plugins10.stdout [new file with mode: 0644]
testsuite/tests/plugins/plugins11.hs [new file with mode: 0644]
testsuite/tests/plugins/plugins11.stdout [new file with mode: 0644]
testsuite/tests/plugins/plugins12.hs [new file with mode: 0644]
testsuite/tests/plugins/plugins13.hs [new file with mode: 0644]
testsuite/tests/plugins/plugins14.hs [new file with mode: 0644]
testsuite/tests/plugins/plugins15.hs [new file with mode: 0644]
testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs [new file with mode: 0644]
testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs [new file with mode: 0644]
testsuite/tests/plugins/simple-plugin/simple-plugin.cabal

index 02e7d50..cc4a424 100644 (file)
@@ -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)
     }}}}
 
 
index 21224eb..516cf0e 100644 (file)
@@ -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!"
index 85c5d07..34f3298 100644 (file)
@@ -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 (file)
index 0000000..206675e
--- /dev/null
@@ -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
index 2738929..5bef07f 100644 (file)
@@ -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 $
index bb31b07..7ed258a 100644 (file)
@@ -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
index 3e983fd..6c823cc 100644 (file)
@@ -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 (file)
index 0000000..06a6799
--- /dev/null
@@ -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 (file)
index 0000000..6dd62d3
--- /dev/null
@@ -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 (file)
index 0000000..b8fe5d6
--- /dev/null
@@ -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 [])
+                         }
index 94d0e2d..34b1162 100644 (file)
@@ -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}')],
index f0acc67..46c0f9c 100644 (file)
@@ -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 (file)
index 0000000..d843c00
--- /dev/null
@@ -0,0 +1 @@
+module A where
diff --git a/testsuite/tests/plugins/plugins09.stdout b/testsuite/tests/plugins/plugins09.stdout
new file mode 100644 (file)
index 0000000..efb740b
--- /dev/null
@@ -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 (file)
index 0000000..d4564a2
--- /dev/null
@@ -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 (file)
index 0000000..737789c
--- /dev/null
@@ -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 (file)
index 0000000..f714472
--- /dev/null
@@ -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 (file)
index 0000000..1e63042
--- /dev/null
@@ -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 (file)
index 0000000..96d35db
--- /dev/null
@@ -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 (file)
index 0000000..273aba2
--- /dev/null
@@ -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 (file)
index 0000000..6f4c2f5
--- /dev/null
@@ -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 (file)
index 0000000..be76019
--- /dev/null
@@ -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 (file)
index 0000000..c64b62f
--- /dev/null
@@ -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 (file)
index 0000000..d5c9dd1
--- /dev/null
@@ -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
index 011ed67..0a3c49e 100644 (file)
@@ -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