diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index fb63b10785dc8b4c46feeb15479842baeddab87d..9e247012cf595bd2d5e0715a15e5792d2d1b71dc 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -663,7 +663,7 @@ setSessionDynFlags dflags0 = do
, iservConfOpts = getOpts dflags opt_i
, iservConfProfiled = profiled
, iservConfDynamic = dynamic
- , iservConfHook = createIservProcessHook (hooks dflags)
+ , iservConfHook = createIservProcessHook (hsc_hooks hsc_env)
, iservConfTrace = tr
}
s <- liftIO $ newMVar IServPending
diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs
index 1ba59130dbf7259c6d5620e80e44f82c4d31995d..ab406878781bfcd4bb1cfec07f927636a0f9b51b 100644
--- a/compiler/GHC/Data/IOEnv.hs
+++ b/compiler/GHC/Data/IOEnv.hs
@@ -36,6 +36,7 @@ module GHC.Data.IOEnv (
import GHC.Prelude
import GHC.Driver.Session
+import {-# SOURCE #-} GHC.Driver.Hooks
import GHC.Utils.Exception
import GHC.Unit.Module
import GHC.Utils.Panic
@@ -111,6 +112,10 @@ instance ContainsDynFlags env => HasDynFlags (IOEnv env) where
getDynFlags = do env <- getEnv
return $! extractDynFlags env
+instance ContainsHooks env => HasHooks (IOEnv env) where
+ getHooks = do env <- getEnv
+ return $! extractHooks env
+
instance ContainsLogger env => HasLogger (IOEnv env) where
getLogger = do env <- getEnv
return $! extractLogger env
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index cbd63c27cb370a9b2929f76395a3d5ee99894360..e541dfe544f1010d9dc10c9b5210ee56c01f3f84 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -4,6 +4,7 @@ module GHC.Driver.Env.Types
, HscEnv(..)
) where
+import {-# SOURCE #-} GHC.Driver.Hooks
import GHC.Driver.Session ( DynFlags, HasDynFlags(..) )
import GHC.Linker.Types ( Loader )
import GHC.Prelude
@@ -155,5 +156,8 @@ data HscEnv
, hsc_logger :: !Logger
-- ^ Logger
+
+ , hsc_hooks :: !Hooks
+ -- ^ Hooks
}
diff --git a/compiler/GHC/Driver/Hooks.hs b/compiler/GHC/Driver/Hooks.hs
index 432297b735cbd808096e4b793b4256eafc7f86c4..cb21072bd6a441ef40df5508bcd605c94c3f9105 100644
--- a/compiler/GHC/Driver/Hooks.hs
+++ b/compiler/GHC/Driver/Hooks.hs
@@ -7,9 +7,9 @@
module GHC.Driver.Hooks
( Hooks
+ , HasHooks (..)
+ , ContainsHooks (..)
, emptyHooks
- , lookupHook
- , getHooked
-- the hooks:
, DsForeignsHook
, dsForeignsHook
@@ -68,7 +68,6 @@ import GHCi.RemoteTypes
import GHC.Data.Stream
import GHC.Data.Bag
-import Data.Maybe
import qualified Data.Kind
import System.Process
@@ -125,33 +124,33 @@ virtually no difference for plugin authors that want to write a foreign hook.
type family DsForeignsHook :: Data.Kind.Type
data Hooks = Hooks
- { dsForeignsHook :: Maybe DsForeignsHook
+ { dsForeignsHook :: !(Maybe DsForeignsHook)
-- ^ Actual type:
-- @Maybe ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))@
- , tcForeignImportsHook :: Maybe ([LForeignDecl GhcRn]
- -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))
- , tcForeignExportsHook :: Maybe ([LForeignDecl GhcRn]
- -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))
- , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult)
+ , tcForeignImportsHook :: !(Maybe ([LForeignDecl GhcRn]
+ -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)))
+ , tcForeignExportsHook :: !(Maybe ([LForeignDecl GhcRn]
+ -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))
+ , hscFrontendHook :: !(Maybe (ModSummary -> Hsc FrontendResult))
, hscCompileCoreExprHook ::
- Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
- , ghcPrimIfaceHook :: Maybe ModIface
- , runPhaseHook :: Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath))
- , runMetaHook :: Maybe (MetaHook TcM)
- , linkHook :: Maybe (GhcLink -> DynFlags -> Bool
- -> HomePackageTable -> IO SuccessFlag)
- , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))
- , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type
- -> IO (Maybe HValue))
- , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)
- , stgToCmmHook :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs
- -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)
- , cmmToRawCmmHook :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
- -> IO (Stream IO RawCmmGroup a))
+ !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue))
+ , ghcPrimIfaceHook :: !(Maybe ModIface)
+ , runPhaseHook :: !(Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)))
+ , runMetaHook :: !(Maybe (MetaHook TcM))
+ , linkHook :: !(Maybe (GhcLink -> DynFlags -> Bool
+ -> HomePackageTable -> IO SuccessFlag))
+ , runRnSpliceHook :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)))
+ , getValueSafelyHook :: !(Maybe (HscEnv -> Name -> Type
+ -> IO (Maybe HValue)))
+ , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))
+ , stgToCmmHook :: !(Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs
+ -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos))
+ , cmmToRawCmmHook :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a
+ -> IO (Stream IO RawCmmGroup a)))
}
-getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a
-getHooked hook def = fmap (lookupHook hook def) getDynFlags
+class HasHooks m where
+ getHooks :: m Hooks
-lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a
-lookupHook hook def = fromMaybe def . hook . hooks
+class ContainsHooks a where
+ extractHooks :: a -> Hooks
diff --git a/compiler/GHC/Driver/Hooks.hs-boot b/compiler/GHC/Driver/Hooks.hs-boot
index 48d6cdb1bc677cee423d96b05ac9db039b414e7e..efc6f5a32dd22df3a3df965415d749ca37cd1c39 100644
--- a/compiler/GHC/Driver/Hooks.hs-boot
+++ b/compiler/GHC/Driver/Hooks.hs-boot
@@ -5,3 +5,9 @@ import GHC.Prelude ()
data Hooks
emptyHooks :: Hooks
+
+class HasHooks m where
+ getHooks :: m Hooks
+
+class ContainsHooks a where
+ extractHooks :: a -> Hooks
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index ab877f6f487bf2eb669381a121f53e12ede11965..6c80c6827ca9f724820360203af9d7870154afa9 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -264,6 +264,7 @@ newHscEnv dflags = do
, hsc_plugins = []
, hsc_static_plugins = []
, hsc_unit_dbs = Nothing
+ , hsc_hooks = emptyHooks
}
-- -----------------------------------------------------------------------------
@@ -718,10 +719,9 @@ hscIncrementalFrontend
compile mb_old_hash reason = do
liftIO $ msg reason
- tc_result <- do
- let def ms = FrontendTypecheck . fst <$> hsc_typecheck False ms Nothing
- action <- getHooked hscFrontendHook def
- action mod_summary
+ tc_result <- case hscFrontendHook (hsc_hooks hsc_env) of
+ Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False mod_summary Nothing
+ Just h -> h mod_summary
return $ Right (tc_result, mb_old_hash)
stable = case source_modified of
@@ -1524,6 +1524,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
+ hooks = hsc_hooks hsc_env
data_tycons = filter isDataTyCon tycons
-- cg_tycons includes newtypes, for the benefit of External Core,
-- but we don't generate any code for newtypes
@@ -1563,8 +1564,9 @@ hscGenHardCode hsc_env cgguts location output_filename = do
------------------ Code output -----------------------
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
- lookupHook (\a -> cmmToRawCmmHook a)
- (\dflg _ -> cmmToRawCmm logger dflg) dflags dflags (Just this_mod) cmms
+ case cmmToRawCmmHook hooks of
+ Nothing -> cmmToRawCmm logger dflags cmms
+ Just h -> h dflags (Just this_mod) cmms
let dump a = do
unless (null a) $
@@ -1617,6 +1619,7 @@ hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
+ let hooks = hsc_hooks hsc_env
home_unit = hsc_home_unit hsc_env
platform = targetPlatform dflags
cmm <- ioMsgMaybe
@@ -1643,8 +1646,11 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
unless (null cmmgroup) $
dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm"
FormatCMM (pdoc platform cmmgroup)
- rawCmms <- lookupHook (\x -> cmmToRawCmmHook x)
- (\dflgs _ -> cmmToRawCmm logger dflgs) dflags dflags Nothing (Stream.yield cmmgroup)
+
+ rawCmms <- case cmmToRawCmmHook hooks of
+ Nothing -> cmmToRawCmm logger dflags (Stream.yield cmmgroup)
+ Just h -> h dflags Nothing (Stream.yield cmmgroup)
+
_ <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] []
rawCmms
return ()
@@ -1686,17 +1692,21 @@ doCodeGen hsc_env this_mod data_tycons
cost_centre_info stg_binds hpc_info = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
+ let hooks = hsc_hooks hsc_env
platform = targetPlatform dflags
let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds
dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)
+ let stg_to_cmm = case stgToCmmHook hooks of
+ Nothing -> StgToCmm.codeGen logger
+ Just h -> h
+
let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
-- See Note [Forcing of stg_binds]
cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}
- lookupHook stgToCmmHook (StgToCmm.codeGen logger) dflags dflags this_mod data_tycons
- cost_centre_info stg_binds_w_fvs hpc_info
+ stg_to_cmm dflags this_mod data_tycons cost_centre_info stg_binds_w_fvs hpc_info
-- codegen consumes a stream of CmmGroup, and produces a new
-- stream of CmmGroup (not necessarily synchronised: one
@@ -2023,8 +2033,10 @@ hscParseThingWithLocation source linenumber parser str = do
%********************************************************************* -}
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
-hscCompileCoreExpr hsc_env =
- lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
+hscCompileCoreExpr hsc_env loc expr =
+ case hscCompileCoreExprHook (hsc_hooks hsc_env) of
+ Nothing -> hscCompileCoreExpr' hsc_env loc expr
+ Just h -> h hsc_env loc expr
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' hsc_env srcspan ds_expr
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index c36e11914e93fd8ba7f8b29253512ff2f2072433..f13d13b1983f00892b68d06dd1d22c908b98dac7 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -617,8 +617,14 @@ load' how_much mHscMessage mod_graph = do
do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
-- link everything together
- unit_env <- hsc_unit_env <$> getSession
- linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env do_linking (hsc_HPT hsc_env1)
+ hsc_env <- getSession
+ linkresult <- liftIO $ link (ghcLink dflags)
+ logger
+ (hsc_hooks hsc_env)
+ dflags
+ (hsc_unit_env hsc_env)
+ do_linking
+ (hsc_HPT hsc_env1)
if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
then do
@@ -677,8 +683,14 @@ load' how_much mHscMessage mod_graph = do
ASSERT( just_linkables ) do
-- Link everything together
- unit_env <- hsc_unit_env <$> getSession
- linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env False hpt5
+ hsc_env <- getSession
+ linkresult <- liftIO $ link (ghcLink dflags)
+ logger
+ (hsc_hooks hsc_env)
+ dflags
+ (hsc_unit_env hsc_env)
+ False
+ hpt5
modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }
loadFinish Failed linkresult
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index f5cbebee51687a2c0f092863918fae5e1d760ba0..df54f35e04e4c473b7399f003645636097f6f5d3 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -484,6 +484,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do
-- libraries.
link :: GhcLink -- ^ interactive or batch
-> Logger -- ^ Logger
+ -> Hooks
-> DynFlags -- ^ dynamic flags
-> UnitEnv -- ^ unit environment
-> Bool -- ^ attempt linking in batch mode?
@@ -497,20 +498,20 @@ link :: GhcLink -- ^ interactive or batch
-- exports main, i.e., we have good reason to believe that linking
-- will succeed.
-link ghcLink logger dflags unit_env
- = lookupHook linkHook l dflags ghcLink dflags
- where
- l k dflags batch_attempt_linking hpt = case k of
- NoLink -> return Succeeded
- LinkBinary -> link' logger dflags unit_env batch_attempt_linking hpt
- LinkStaticLib -> link' logger dflags unit_env batch_attempt_linking hpt
- LinkDynLib -> link' logger dflags unit_env batch_attempt_linking hpt
- LinkInMemory
- | platformMisc_ghcWithInterpreter $ platformMisc dflags
- -> -- Not Linking...(demand linker will do the job)
- return Succeeded
- | otherwise
- -> panicBadLink LinkInMemory
+link ghcLink logger hooks dflags unit_env batch_attempt_linking hpt =
+ case linkHook hooks of
+ Nothing -> case ghcLink of
+ NoLink -> return Succeeded
+ LinkBinary -> link' logger dflags unit_env batch_attempt_linking hpt
+ LinkStaticLib -> link' logger dflags unit_env batch_attempt_linking hpt
+ LinkDynLib -> link' logger dflags unit_env batch_attempt_linking hpt
+ LinkInMemory
+ | platformMisc_ghcWithInterpreter $ platformMisc dflags
+ -> -- Not Linking...(demand linker will do the job)
+ return Succeeded
+ | otherwise
+ -> panicBadLink LinkInMemory
+ Just h -> h ghcLink dflags batch_attempt_linking hpt
panicBadLink :: GhcLink -> a
@@ -937,8 +938,10 @@ pipeLoop phase input_fn = do
runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)
runHookedPhase pp input = do
- dflags <- hsc_dflags <$> getPipeSession
- lookupHook runPhaseHook runPhase dflags pp input
+ hooks <- hsc_hooks <$> getPipeSession
+ case runPhaseHook hooks of
+ Nothing -> runPhase pp input
+ Just h -> h pp input
-- -----------------------------------------------------------------------------
-- In each phase, we need to know into what filename to generate the
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 5e76da3490ac6e5880914fc18dd83a9032f2c967..7afcf7309ce3649b1220fd42c762dfb0c411f6cf 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -231,7 +231,6 @@ import GHC.Unit.Types
import GHC.Unit.Parser
import GHC.Unit.Module
import GHC.Builtin.Names ( mAIN_NAME )
-import {-# SOURCE #-} GHC.Driver.Hooks
import GHC.Driver.Phases ( Phase(..), phaseInputExt )
import GHC.Driver.Flags
import GHC.Driver.Backend
@@ -551,9 +550,6 @@ data DynFlags = DynFlags {
-- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*
-- order that they're specified on the command line.
- -- GHC API hooks
- hooks :: Hooks,
-
-- For ghc -M
depMakefile :: FilePath,
depIncludePkgDeps :: Bool,
@@ -1172,7 +1168,6 @@ defaultDynFlags mySettings llvmConfig =
pluginModNames = [],
pluginModNameOpts = [],
frontendPluginOpts = [],
- hooks = emptyHooks,
outputFile_ = Nothing,
dynOutputFile_ = Nothing,
diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs
index f6de90de64afacd7aaf696307326a83d13526df8..4249204615bf6d1948d63f612ea9b2448ec72a0c 100644
--- a/compiler/GHC/HsToCore/Foreign/Decl.hs
+++ b/compiler/GHC/HsToCore/Foreign/Decl.hs
@@ -82,9 +82,12 @@ so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with thes
type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-- the occurrence analyser will sort it all out
-dsForeigns :: [LForeignDecl GhcTc]
- -> DsM (ForeignStubs, OrdList Binding)
-dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)
+dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
+dsForeigns fos = do
+ hooks <- getHooks
+ case dsForeignsHook hooks of
+ Nothing -> dsForeigns' fos
+ Just h -> h fos
dsForeigns' :: [LForeignDecl GhcTc]
-> DsM (ForeignStubs, OrdList Binding)
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 8a1750909b5208a8fc0b3f95621b876f10e6c99d..e8f1c625923c2665dd7e00cab24c212e42c75aaa 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -840,9 +840,11 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file
-- TODO: make this check a function
if mod `installedModuleEq` gHC_PRIM
then do
- iface <- getHooked ghcPrimIfaceHook ghcPrimIface
- return (Succeeded (iface,
- "<built in interface for GHC.Prim>"))
+ hooks <- getHooks
+ let iface = case ghcPrimIfaceHook hooks of
+ Nothing -> ghcPrimIface
+ Just h -> h
+ return (Succeeded (iface, "<built in interface for GHC.Prim>"))
else do
dflags <- getDynFlags
-- Look for the file
diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs
index 30698d0f986173c94302c2091d337c69927c4210..885fdf17fd1fcea27cf8c639230821cf7489d48c 100644
--- a/compiler/GHC/Rename/Splice.hs
+++ b/compiler/GHC/Rename/Splice.hs
@@ -20,6 +20,7 @@ import GHC.Types.Name.Set
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Tc.Utils.Monad
+import GHC.Driver.Env.Types
import GHC.Rename.Env
import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn )
@@ -314,7 +315,10 @@ runRnSplice :: UntypedSpliceFlavour
-> HsSplice GhcRn -- Always untyped
-> TcRn (res, [ForeignRef (TH.Q ())])
runRnSplice flavour run_meta ppr_res splice
- = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)
+ = do { hooks <- hsc_hooks <$> getTopEnv
+ ; splice' <- case runRnSpliceHook hooks of
+ Nothing -> return splice
+ Just h -> h splice
; let the_expr = case splice' of
HsUntypedSplice _ _ _ e -> e
diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs
index 683860ff20663fd6740eec77862fd36645f620e4..73ad45c246502f1538b35061e1a0d84e53286807 100644
--- a/compiler/GHC/Runtime/Loader.hs
+++ b/compiler/GHC/Runtime/Loader.hs
@@ -188,7 +188,9 @@ forceLoadTyCon hsc_env con_name = do
getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely hsc_env val_name expected_type = do
- mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
+ mb_hval <- case getValueSafelyHook hooks of
+ Nothing -> getHValueSafely hsc_env val_name expected_type
+ Just h -> h hsc_env val_name expected_type
case mb_hval of
Nothing -> return Nothing
Just hval -> do
@@ -197,6 +199,7 @@ getValueSafely hsc_env val_name expected_type = do
where
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
+ hooks = hsc_hooks hsc_env
getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
getHValueSafely hsc_env val_name expected_type = do
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index b40386e51387c6af8c84e296503c9ec475d80571..47d6e62997b05bdf885a1abe6c138d65b84d0c81 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -216,8 +216,11 @@ to the module's usages.
tcForeignImports :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
-tcForeignImports decls
- = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)
+tcForeignImports decls = do
+ hooks <- getHooks
+ case tcForeignImportsHook hooks of
+ Nothing -> tcForeignImports' decls
+ Just h -> h decls
tcForeignImports' :: [LForeignDecl GhcRn]
-> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
@@ -359,8 +362,11 @@ checkMissingAmpersand dflags arg_tys res_ty
tcForeignExports :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
-tcForeignExports decls =
- getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)
+tcForeignExports decls = do
+ hooks <- getHooks
+ case tcForeignExportsHook hooks of
+ Nothing -> tcForeignExports' decls
+ Just h -> h decls
tcForeignExports' :: [LForeignDecl GhcRn]
-> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index fab5a13c9bd042abe9edf64cc500297753bd6d44..ab45f3f3738379b8c49271c18dd533294d75dbef 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -870,9 +870,11 @@ runQResult show_th f runQ expr_span hval
runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)
-> LHsExpr GhcTc
-> TcM hs_syn
-runMeta unwrap e
- = do { h <- getHooked runMetaHook defaultRunMeta
- ; unwrap h e }
+runMeta unwrap e = do
+ hooks <- getHooks
+ case runMetaHook hooks of
+ Nothing -> unwrap defaultRunMeta e
+ Just h -> unwrap h e
defaultRunMeta :: MetaHook TcM
defaultRunMeta (MetaE r)
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 2a54afc570ae88b7e3b16f35da9e94100b8eb55f..d70474393f2220508291c66c1a8439b0b5ae755c 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -89,6 +89,7 @@ import GHC.Platform
import GHC.Driver.Env
import GHC.Driver.Session
+import {-# SOURCE #-} GHC.Driver.Hooks
import GHC.Hs
@@ -237,6 +238,9 @@ data Env gbl lcl
instance ContainsDynFlags (Env gbl lcl) where
extractDynFlags env = hsc_dflags (env_top env)
+instance ContainsHooks (Env gbl lcl) where
+ extractHooks env = hsc_hooks (env_top env)
+
instance ContainsLogger (Env gbl lcl) where
extractLogger env = hsc_logger (env_top env)
diff --git a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
index 7d8a6b909c9807fa6ec21cf9f6c7ac86ff33f4c0..33c1ab78beb3453d9727eeab3b2436b8604795d6 100644
--- a/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
+++ b/testsuite/tests/plugins/hooks-plugin/Hooks/Plugin.hs
@@ -15,12 +15,9 @@ plugin = defaultPlugin { driverPlugin = hooksP }
hooksP :: [CommandLineOption] -> HscEnv -> IO HscEnv
hooksP opts hsc_env = do
- let dflags = hsc_dflags hsc_env
- dflags' = dflags
- { hooks = (hooks dflags)
- { runMetaHook = Just (fakeRunMeta opts) }
- }
- hsc_env' = hsc_env { hsc_dflags = dflags' }
+ let hooks = hsc_hooks hsc_env
+ hooks' = hooks { runMetaHook = Just (fakeRunMeta opts) }
+ hsc_env' = hsc_env { hsc_hooks = hooks' }
return hsc_env'
-- This meta hook doesn't actually care running code in splices,