diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index 87a9727f5..5f8d903f4 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -71,9 +71,11 @@ import qualified HeaderInfo as Hdr import HscMain (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive) import MkIface import StringBuffer as SB -import TcRnMonad (finalSafeMode, TcGblEnv, tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins, tcg_binds) +import TcRnMonad (TcM, finalSafeMode, TcGblEnv, tct_id, TcTyThing(AGlobal, ATcId), initTc, initIfaceLoad, tcg_th_coreplugins, tcg_binds) import TcIface (typecheckIface) import TidyPgm +import Hooks +import TcSplice import Control.Exception.Safe import Control.Monad.Extra @@ -148,20 +150,40 @@ typecheckModule (IdeDefer defer) hsc pm = do where demoteIfDefer = if defer then demoteTypeErrorsToWarnings else id +-- | Add a Hook to the DynFlags which captures and returns the +-- typechecked splices before they are run. This information +-- is used for hover. +captureSplices :: DynFlags -> (DynFlags -> IO a) -> IO (a, [LHsExpr GhcTc]) +captureSplices dflags k = do + splice_ref <- newIORef [] + res <- k (dflags { hooks = addSpliceHook splice_ref (hooks dflags)}) + splices <- readIORef splice_ref + return (res, splices) + where + addSpliceHook :: IORef [LHsExpr GhcTc] -> Hooks -> Hooks + addSpliceHook var h = h { runMetaHook = Just (splice_hook var) } + + splice_hook :: IORef [LHsExpr GhcTc] -> MetaRequest -> LHsExpr GhcTc -> TcM MetaResult + splice_hook var mr e = do + liftIO $ modifyIORef var (e:) + pprTraceM "expr" (ppr e) + defaultRunMeta mr e + tcRnModule :: GhcMonad m => ParsedModule -> m TcModuleResult tcRnModule pmod = do let ms = pm_mod_summary pmod hsc_env <- getSession - let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } - (tc_gbl_env, mrn_info) - <- liftIO $ hscTypecheckRename hsc_env_tmp ms $ - HsParsedModule { hpm_module = parsedSource pmod, - hpm_src_files = pm_extra_src_files pmod, - hpm_annotations = pm_annotations pmod } + ((tc_gbl_env, mrn_info), splices) + <- liftIO $ captureSplices (ms_hspp_opts ms) $ \dflags -> + do let hsc_env_tmp = hsc_env { hsc_dflags = dflags } + hscTypecheckRename hsc_env_tmp ms $ + HsParsedModule { hpm_module = parsedSource pmod, + hpm_src_files = pm_extra_src_files pmod, + hpm_annotations = pm_annotations pmod } let rn_info = case mrn_info of Just x -> x Nothing -> error "no renamed info tcRnModule" - pure (TcModuleResult pmod rn_info tc_gbl_env False) + pure (TcModuleResult pmod rn_info tc_gbl_env splices False) mkHiFileResultNoCompile :: HscEnv -> TcModuleResult -> IO HiFileResult mkHiFileResultNoCompile session tcm = do diff --git a/src/Development/IDE/Core/RuleTypes.hs b/src/Development/IDE/Core/RuleTypes.hs index 733d80f26..ef223ce9b 100644 --- a/src/Development/IDE/Core/RuleTypes.hs +++ b/src/Development/IDE/Core/RuleTypes.hs @@ -91,6 +91,7 @@ data TcModuleResult = TcModuleResult { tmrParsed :: ParsedModule , tmrRenamed :: RenamedSource , tmrTypechecked :: TcGblEnv + , tmrTopLevelSplices :: [LHsExpr GhcTc] -- ^ Typechecked top-level splices from this module , tmrDeferedError :: !Bool -- ^ Did we defer any type errors for this module? } instance Show TcModuleResult where