Commit dc8c03b2 authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

Run typeCheckResultAction and renamedResultAction in TcM rather than Hsc

The primary motivation for this is that this allows users to access
the warnings and error machinery present in TcM. However, it also allows
users to use TcM actions which means they can typecheck GhcPs which
could be significantly easier than constructing GhcTc.

Reviewers: bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #15229

Differential Revision: https://phabricator.haskell.org/D4792
parent fa34ced5
......@@ -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!"
......
......@@ -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.
......
......@@ -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
......@@ -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 = ()}
......
......@@ -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)
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment