diff options
| -rw-r--r-- | compiler/main/HscMain.hs | 39 | ||||
| -rw-r--r-- | compiler/main/Plugins.hs | 8 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 57 | ||||
| -rw-r--r-- | docs/users_guide/extending_ghc.rst | 76 | ||||
| -rw-r--r-- | testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs | 2 | ||||
| -rw-r--r-- | testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs | 4 |
6 files changed, 100 insertions, 86 deletions
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 516cf0e586..cf8e911369 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -85,7 +85,7 @@ module HscMain import GhcPrelude import Data.Data hiding (Fixity, TyCon) -import Data.Maybe ( isJust, fromMaybe ) +import Data.Maybe ( isJust ) import DynFlags (addPluginModuleName) import Id import GHCi ( addSptEntry ) @@ -101,7 +101,6 @@ import Panic import ConLike import Control.Concurrent -import Avail ( Avails ) import Module import Packages import RdrName @@ -391,18 +390,12 @@ hscParse' mod_summary = 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. -type RenamedStuff = - (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], - Maybe LHsDocString)) -- ----------------------------------------------------------------------------- -- | 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 - let rn_info = get_renamed_stuff tc_result + let rn_info = getRenamedStuff tc_result dflags <- getDynFlags liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $ @@ -410,12 +403,6 @@ 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 @@ -474,7 +461,7 @@ tcRnModule' sum save_rn_syntax mod = do tcg_res <- {-# SCC "Typecheck-Rename" #-} ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src sum) + tcRnModule hsc_env sum (save_rn_syntax || plugin_needs_rn) mod -- See Note [Safe Haskell Overlapping Instances Implementation] @@ -508,23 +495,9 @@ tcRnModule' sum save_rn_syntax mod = do 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' + + + 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 34f3298b0d..0ad46bdb99 100644 --- a/compiler/main/Plugins.hs +++ b/compiler/main/Plugins.hs @@ -59,13 +59,13 @@ data Plugin = Plugin { -- ^ Modify the module when it is parsed. This is called by -- HscMain when the parsing is successful. , renamedResultAction :: Maybe ([CommandLineOption] -> ModSummary - -> RenamedSource -> Hsc ()) + -> RenamedSource -> TcM ()) -- ^ 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. + -> TcM TcGblEnv + -- ^ Modify the module when it is type checked. This is called add the + -- very end of typechecking. , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -- ^ Modify the TH splice or quasiqoute before it is run. diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 7730f7efd6..21aa59bcb1 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -42,6 +42,7 @@ module TcRnDriver ( badReexportedBootThing, checkBootDeclM, missingBootThing, + getRenamedStuff, RenamedStuff ) where import GhcPrelude @@ -60,7 +61,7 @@ import RnFixity ( lookupFixityRn ) import MkId import TidyPgm ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) -import Plugins ( tcPlugin, LoadedPlugin(..)) +import Plugins import DynFlags import HsSyn import IfaceSyn ( ShowSub(..), showToHeader ) @@ -148,12 +149,12 @@ import Control.Monad -- | Top level entry point for typechecker and renamer tcRnModule :: HscEnv - -> HscSource + -> ModSummary -> Bool -- True <=> save renamed syntax -> HsParsedModule -> IO (Messages, Maybe TcGblEnv) -tcRnModule hsc_env hsc_src save_rn_syntax +tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module=L loc this_module} | RealSrcSpan real_loc <- loc = withTiming (pure dflags) @@ -162,12 +163,13 @@ tcRnModule hsc_env hsc_src save_rn_syntax initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ withTcPlugins hsc_env $ - tcRnModuleTcRnM hsc_env hsc_src parsedModule pair + tcRnModuleTcRnM hsc_env mod_sum parsedModule pair | otherwise = return ((emptyBag, unitBag err_msg), Nothing) where + hsc_src = ms_hsc_src mod_sum dflags = hsc_dflags hsc_env err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod @@ -186,13 +188,13 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcRnModuleTcRnM :: HscEnv - -> HscSource + -> ModSummary -> HsParsedModule -> (Module, SrcSpan) -> TcRn TcGblEnv -- Factored out separately from tcRnModule so that a Core plugin can -- call the type checker directly -tcRnModuleTcRnM hsc_env hsc_src +tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module = (L loc (HsModule maybe_mod export_ies @@ -202,8 +204,8 @@ tcRnModuleTcRnM hsc_env hsc_src }) (this_mod, prel_imp_loc) = setSrcSpan loc $ - do { let { explicit_mod_hdr = isJust maybe_mod } ; - + do { let { explicit_mod_hdr = isJust maybe_mod + ; hsc_src = ms_hsc_src mod_sum }; -- Load the hi-boot interface for this module, if any -- We do this now so that the boot_names can be passed -- to tcTyAndClassDecls, because the boot_names are @@ -288,6 +290,9 @@ tcRnModuleTcRnM hsc_env hsc_src -- add extra source files to tcg_dependent_files addDependentFiles src_files ; + runRenamerPlugin mod_sum hsc_env tcg_env ; + tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env ; + -- Dump output and return tcDump tcg_env ; return tcg_env @@ -2698,3 +2703,39 @@ withTcPlugins hsc_env m = getTcPlugins :: DynFlags -> [TcPlugin] getTcPlugins dflags = catMaybes $ map get_plugin (plugins dflags) where get_plugin p = tcPlugin (lpPlugin p) (lpArguments p) + +runRenamerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM () +runRenamerPlugin mod_sum hsc_env gbl_env = do + let dflags = hsc_dflags hsc_env + case getRenamedStuff gbl_env of + Just rn -> + withPlugins_ dflags + (\p opts -> (fromMaybe (\_ _ _ -> return ()) + (renamedResultAction p)) opts mod_sum) + rn + Nothing -> return () + +-- 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. +type RenamedStuff = + (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], + Maybe LHsDocString)) + +-- | Extract the renamed information from TcGblEnv. +getRenamedStuff :: TcGblEnv -> RenamedStuff +getRenamedStuff 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) + +runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv +runTypecheckerPlugin sum hsc_env gbl_env = do + let dflags = hsc_dflags hsc_env + unsafeText = "Use of plugins makes the module unsafe" + pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan + (Outputable.text unsafeText) ) + mark_unsafe = recordUnsafeInfer pluginUnsafe + withPlugins dflags + (\p opts env -> mark_unsafe >> typeCheckResultAction p opts sum env) + gbl_env diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst index 7ed258a090..a0d3db668d 100644 --- a/docs/users_guide/extending_ghc.rst +++ b/docs/users_guide/extending_ghc.rst @@ -131,8 +131,8 @@ when invoked: import GHC import GHC.Paths ( libdir ) import DynFlags ( defaultLogAction ) - - main = + + main = defaultErrorHandler defaultLogAction $ do runGhc (Just libdir) $ do dflags <- getSessionDynFlags @@ -157,7 +157,7 @@ Compiling it results in: [1 of 1] Compiling Main ( simple_ghc_api.hs, simple_ghc_api.o ) Linking simple_ghc_api ... $ ./simple_ghc_api - $ ./test_main + $ ./test_main hi $ @@ -425,7 +425,7 @@ in a module it compiles: where printBind :: DynFlags -> CoreBind -> CoreM CoreBind printBind dflags bndr@(NonRec b _) = do putMsgS $ "Non-recursive binding named " ++ showSDoc dflags (ppr b) - return bndr + return bndr printBind _ bndr = return bndr .. _getting-annotations: @@ -610,14 +610,14 @@ 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 +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 { + plugin = defaultPlugin { parsedResultAction = parsed , typeCheckResultAction = typechecked , spliceRunAction = spliceRun @@ -630,15 +630,15 @@ 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 +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 + parsed :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule -The ``ModSummary`` contains useful +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 @@ -647,33 +647,33 @@ 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 +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 +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 + typechecked :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv -By overriding the ``renamedResultAction`` field with a ``Just`` function, you +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. +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 ()) + rename :: Maybe ([CommandLineOption] -> ModSummary -> TcM ()) 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 +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 @@ -696,7 +696,7 @@ 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 +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. @@ -713,10 +713,10 @@ 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 +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. @@ -736,36 +736,36 @@ displayed. plugin :: Plugin plugin = defaultPlugin { parsedResultAction = parsedPlugin , renamedResultAction = Just renamedAction - , typeCheckResultAction = typecheckPlugin + , typeCheckResultAction = typecheckPlugin , spliceRunAction = metaPlugin , interfaceLoadAction = interfaceLoadPlugin } parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule - parsedPlugin _ _ pm + parsedPlugin _ _ pm = do liftIO $ putStrLn $ "parsePlugin: \n" ++ (showSDocUnsafe $ ppr $ hpm_module pm) return pm - renamedAction :: [CommandLineOption] -> ModSummary + renamedAction :: [CommandLineOption] -> ModSummary -> ( HsGroup GhcRn, [LImportDecl GhcRn] - , Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString ) - -> Hsc () + , Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString ) + -> TcM () renamedAction _ _ ( gr, _, _, _ ) = liftIO $ putStrLn "typeCheckPlugin (rn): " ++ (showSDocUnsafe $ ppr gr) - typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> Hsc TcGblEnv - typecheckPlugin _ _ tc + typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM 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 + metaPlugin _ meta = do liftIO $ putStrLn $ "meta: " ++ (showSDocUnsafe $ ppr meta) return meta interfaceLoadPlugin :: [CommandLineOption] -> ModIface -> IfM lcl ModIface - interfaceLoadPlugin _ iface + interfaceLoadPlugin _ iface = do liftIO $ putStrLn $ "interface loaded: " ++ (showSDocUnsafe $ ppr $ mi_module iface) return iface @@ -785,7 +785,7 @@ output: .. code-block:: none - parsePlugin: + parsePlugin: module A where a = () $(return []) @@ -797,9 +797,9 @@ output: interface loaded: GHC.Types meta: return [] interface loaded: GHC.Integer.Type - typeCheckPlugin (rn): + typeCheckPlugin (rn): Just a = () - typeCheckPlugin (tc): + typeCheckPlugin (tc): {$trModule = Module (TrNameS "main"#) (TrNameS "A"#), a = ()} diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index c64b62f8a7..2d14eeaf85 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -39,7 +39,7 @@ removeParsedBinding name (L l m) = occNameString (rdrNameOcc fid) /= name notNamedAs _ _ = True -typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> Hsc TcGblEnv +typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv typecheckPlugin [name, "typecheck"] _ tc = return $ tc { tcg_exports = filter (availNotNamedAs name) (tcg_exports tc) , tcg_binds = filterBag (notNamedAs name) (tcg_binds tc) diff --git a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs index d5c9dd1856..85fc870604 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs @@ -31,11 +31,11 @@ parsedPlugin opts _ pm renamedAction :: [CommandLineOption] -> ModSummary -> ( HsGroup GhcRn, [LImportDecl GhcRn] , Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString ) - -> Hsc () + -> TcM () renamedAction _ _ ( gr, _, _, _ ) = liftIO $ putStrLn "typeCheckPlugin (rn)" -typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> Hsc TcGblEnv +typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv typecheckPlugin _ _ tc = do liftIO $ putStrLn "typeCheckPlugin (tc)" return tc |