diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/iface/LoadIface.hs | 5 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 104 | ||||
| -rw-r--r-- | compiler/main/Plugins.hs | 69 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs-boot | 37 | ||||
| -rw-r--r-- | compiler/typecheck/TcSplice.hs | 8 |
5 files changed, 176 insertions, 47 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 $ |