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