From e41ef181b52423140978f976a51c9a2aa7262c04 Mon Sep 17 00:00:00 2001 From: Matthew Pickering Date: Wed, 5 Oct 2022 11:30:16 +0100 Subject: [PATCH] Simplify implementation of eval plugin The plugin was implemented by calling "load" which circumvents all of HLSs caching mechanisms for interface files and linkables. Instead we should work like the other typechecking functions which get all the stuff we need using HLS rules and setup the HscEnv with all the state in the right places. The key part to this is setting up all the HPT modules with linkables if they are depenedencies of the module we are trying to run a function from. --- ghcide/src/Development/IDE/Core/Compile.hs | 26 +- ghcide/src/Development/IDE/Core/Rules.hs | 1 + ghcide/src/Development/IDE/GHC/Compat.hs | 24 ++ .../src/Ide/Plugin/Eval/Code.hs | 8 +- .../src/Ide/Plugin/Eval/CodeLens.hs | 249 ++++++------------ 5 files changed, 105 insertions(+), 203 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs index e6094a470d..5831b40607 100644 --- a/ghcide/src/Development/IDE/Core/Compile.hs +++ b/ghcide/src/Development/IDE/Core/Compile.hs @@ -308,7 +308,7 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do mods_transitive = getTransitiveMods hsc_env needed_mods -- If we don't support multiple home units, ModuleNames are sufficient because all the units will be the same - mods_transitive_list = + mods_transitive_list = #if MIN_VERSION_ghc(9,3,0) mapMaybe nodeKeyToInstalledModule $ Set.toList mods_transitive #else @@ -362,7 +362,7 @@ captureSplicesAndDeps TypecheckHelpers{..} env k = do #endif -- Compute the transitive set of linkables required - getTransitiveMods hsc_env needed_mods + getTransitiveMods hsc_env needed_mods #if MIN_VERSION_ghc(9,3,0) = Set.unions (Set.fromList (map moduleToNodeKey mods) : [ dep | m <- mods , Just dep <- [Map.lookup (moduleToNodeKey m) (mgTransDeps (hsc_mod_graph hsc_env))] @@ -1000,28 +1000,6 @@ handleGenerationErrors' dflags source action = . (("Error during " ++ T.unpack source) ++) . show @SomeException ] --- | Load modules, quickly. Input doesn't need to be desugared. --- A module must be loaded before dependent modules can be typechecked. --- This variant of loadModuleHome will *never* cause recompilation, it just --- modifies the session. --- The order modules are loaded is important when there are hs-boot files. --- In particular you should make sure to load the .hs version of a file after the --- .hs-boot version. -loadModulesHome - :: [HomeModInfo] - -> HscEnv - -> HscEnv -loadModulesHome mod_infos e = -#if MIN_VERSION_ghc(9,3,0) - hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) -#else - let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] - in e { hsc_HPT = new_modules - , hsc_type_env_var = Nothing - } - where - mod_name = moduleName . mi_module . hm_iface -#endif -- Merge the HPTs, module graphs and FinderCaches -- See Note [GhcSessionDeps] in Development.IDE.Core.Rules diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 72313a4661..cc9812de83 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -57,6 +57,7 @@ module Development.IDE.Core.Rules( typeCheckRuleDefinition, getRebuildCount, getSourceFileSource, + currentLinkables, GhcSessionDepsConfig(..), Log(..), DisplayTHWarning(..), diff --git a/ghcide/src/Development/IDE/GHC/Compat.hs b/ghcide/src/Development/IDE/GHC/Compat.hs index ae4d57e715..7aca5ba16f 100644 --- a/ghcide/src/Development/IDE/GHC/Compat.hs +++ b/ghcide/src/Development/IDE/GHC/Compat.hs @@ -96,6 +96,7 @@ module Development.IDE.GHC.Compat( icInteractiveModule, HomePackageTable, lookupHpt, + loadModulesHome, #if MIN_VERSION_ghc(9,3,0) Dependencies(dep_direct_mods), #else @@ -695,3 +696,26 @@ combineRealSrcSpans span1 span2 (srcSpanEndLine span2, srcSpanEndCol span2) file = srcSpanFile span1 #endif + +-- | Load modules, quickly. Input doesn't need to be desugared. +-- A module must be loaded before dependent modules can be typechecked. +-- This variant of loadModuleHome will *never* cause recompilation, it just +-- modifies the session. +-- The order modules are loaded is important when there are hs-boot files. +-- In particular you should make sure to load the .hs version of a file after the +-- .hs-boot version. +loadModulesHome + :: [HomeModInfo] + -> HscEnv + -> HscEnv +loadModulesHome mod_infos e = +#if MIN_VERSION_ghc(9,3,0) + hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug mod_infos) (e { hsc_type_env_vars = emptyKnotVars }) +#else + let !new_modules = addListToHpt (hsc_HPT e) [(mod_name x, x) | x <- mod_infos] + in e { hsc_HPT = new_modules + , hsc_type_env_var = Nothing + } + where + mod_name = moduleName . mi_module . hm_iface +#endif diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs index dd109f0b44..10efbd05c3 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/Code.hs @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -Wwarn -fno-warn-orphans #-} -- | Expression execution -module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, evalSetup, propSetup, testCheck, asStatements,myExecStmt) where +module Ide.Plugin.Eval.Code (Statement, testRanges, resultRange, propSetup, testCheck, asStatements,myExecStmt) where import Control.Lens ((^.)) import Control.Monad.IO.Class @@ -80,12 +80,6 @@ asStmts (Property t _ _) = ["prop11 = " ++ t, "(propEvaluation prop11 :: IO String)"] --- |GHC declarations required for expression evaluation -evalSetup :: Ghc () -evalSetup = do - preludeAsP <- parseImportDecl "import qualified Prelude as P" - context <- getContext - setContext (IIDecl preludeAsP : context) -- | A wrapper of 'InteractiveEval.execStmt', capturing the execution result myExecStmt :: String -> ExecOptions -> Ghc (Either String (Maybe String)) diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 2ed90bab48..f3c964d9b0 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -29,74 +29,69 @@ import Control.Exception (try) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) -import Control.Monad (guard, join, +import Control.Monad (guard, void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans (lift) import Control.Monad.Trans.Except (ExceptT (..)) import Data.Aeson (toJSON) import Data.Char (isSpace) -import Data.Default import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, find, intercalate, intersperse) -import Data.Maybe (catMaybes, - fromMaybe) +import Data.Maybe (catMaybes) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (getCurrentTime) import Data.Typeable (Typeable) -import Development.IDE (GetDependencyInformation (..), - GetLinkable (..), - GetModSummary (..), - GhcSessionIO (..), - IdeState, - ModSummaryResult (..), - NeedsCompilation (NeedsCompilation), - VFSModified (..), - evalGhcEnv, - hscEnvWithImportPaths, - linkableHomeMod, - printOutputable, - runAction, - textToStringBuffer, - toNormalizedFilePath', - uriToFilePath', - useNoFile_, - useWithStale_, - use_, uses_) -import Development.IDE.Core.Rules (GhcSessionDepsConfig (..), - ghcSessionDepsDefinition) +import Development.IDE.Core.RuleTypes + ( NeedsCompilation(NeedsCompilation), + LinkableResult(linkableHomeMod) ) +import Development.IDE.Core.Rules ( currentLinkables, runAction, IdeState ) +import Development.IDE.Core.Shake + ( useWithStale_, + use_, + uses_ ) +import Development.IDE.GHC.Util + ( printOutputable, evalGhcEnv, modifyDynFlags ) +import Development.IDE.Types.Location + ( toNormalizedFilePath', uriToFilePath' ) import Development.IDE.GHC.Compat hiding (typeKind, unitState) -import qualified Development.IDE.GHC.Compat as Compat -import qualified Development.IDE.GHC.Compat as SrcLoc import Development.IDE.GHC.Compat.Util (GhcException, OverridingBool (..)) import Development.IDE.Import.DependencyInformation (reachableModules) -import Development.IDE.Types.Options import GHC (ClsInst, ExecOptions (execLineNumber, execSourceFile), FamInst, GhcMonad, - LoadHowMuch (LoadAllTargets), NamedThing (getName), defaultFixity, execOptions, exprType, getInfo, getInteractiveDynFlags, - isImport, isStmt, - load, parseName, + isImport, isStmt, parseName, pprFamInst, pprInstance, - setTargets, typeKind) + + +import Development.IDE.Core.RuleTypes + ( ModSummaryResult(msrModSummary), + GetModSummary(GetModSummary), + GhcSessionDeps(GhcSessionDeps), + GetDependencyInformation(GetDependencyInformation), + GetLinkable(GetLinkable) ) +import Development.IDE.Core.Shake ( VFSModified(VFSUnmodified) ) +import Development.IDE.Types.HscEnvEq ( HscEnvEq(hscEnv) ) +import qualified Development.IDE.GHC.Compat.Core as Compat + ( InteractiveImport(IIModule) ) +import qualified Development.IDE.GHC.Compat.Core as SrcLoc + ( unLoc, HasSrcSpan(getLoc) ) #if MIN_VERSION_ghc(9,2,0) -import GHC (Fixity) #endif import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) @@ -108,7 +103,6 @@ import GHC.Types.SrcLoc (UnhelpfulSpanReas #endif import Ide.Plugin.Eval.Code (Statement, asStatements, - evalSetup, myExecStmt, propSetup, resultRange, @@ -232,115 +226,22 @@ runEvalCmd plId st EvalParams{..} = let nfp = toNormalizedFilePath' fp mdlText <- moduleText _uri - -- enable codegen + -- enable codegen for the module which we need to evaluate. liftIO $ queueForEvaluation st nfp liftIO $ setSomethingModified VFSUnmodified st [toKey NeedsCompilation nfp] "Eval" + -- Setup a session with linkables for all dependencies and GHCi specific options + final_hscEnv <- liftIO $ initialiseSessionForEval + (needsQuickCheck tests) + st nfp - session <- runGetSession st nfp - - ms <- fmap msrModSummary $ - liftIO $ - runAction "runEvalCmd.getModSummary" st $ - use_ GetModSummary nfp - - now <- liftIO getCurrentTime - - let modName = moduleName $ ms_mod ms - thisModuleTarget = - Target - (TargetFile fp Nothing) - False - (Just (textToStringBuffer mdlText, now)) - - -- Setup environment for evaluation - hscEnv' <- ExceptT $ fmap join $ liftIO . gStrictTry . evalGhcEnv session $ do - env <- getSession - - -- Install the module pragmas and options - df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms - - -- Restore the original import paths - let impPaths = importPaths $ hsc_dflags env - df <- return df{importPaths = impPaths} - - -- Set the modified flags in the session - _lp <- setSessionDynFlags df - - -- property tests need QuickCheck - when (needsQuickCheck tests) $ void $ addPackages ["QuickCheck"] - dbg "QUICKCHECK NEEDS" $ needsQuickCheck tests - dbg "QUICKCHECK HAS" $ hasQuickCheck df - - -- copy the package state to the interactive DynFlags - idflags <- getInteractiveDynFlags - df <- getSessionDynFlags - -- set the identical DynFlags as GHCi - -- Source: https://github.com/ghc/ghc/blob/5abf59976c7335df760e5d8609d9488489478173/ghc/GHCi/UI.hs#L473-L483 - -- This needs to be done manually since the default flags are not visible externally. - let df' = flip xopt_set LangExt.ExtendedDefaultRules - . flip xopt_unset LangExt.MonomorphismRestriction - $ idflags - setInteractiveDynFlags $ df' -#if MIN_VERSION_ghc(9,0,0) - { - packageFlags = - packageFlags - df - , useColor = Never - , canUseColor = False - } -#else - { pkgState = - pkgState - df - , pkgDatabase = - pkgDatabase - df - , packageFlags = - packageFlags - df - , useColor = Never - , canUseColor = False - } -#endif - - -- Load the module with its current content (as the saved module might not be up to date) - -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8 - -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066 - -- and https://hackage.haskell.org/package/ghc-8.10.1/docs/GHC.html#v:TargetFile - eSetTarget <- gStrictTry $ setTargets [thisModuleTarget] - dbg "setTarget" eSetTarget - - -- load the module in the interactive environment - loadResult <- perf "loadModule" $ load LoadAllTargets - dbg "LOAD RESULT" $ printOutputable loadResult - case loadResult of - Failed -> liftIO $ do - let err = "" - dbg "load ERR" err - return $ Left err - Succeeded -> do - -- Evaluation takes place 'inside' the module - setContext [Compat.IIModule modName] - Right <$> getSession evalCfg <- lift $ getEvalConfig plId - -- Get linkables for all modules below us - -- This can be optimised to only get the linkables for the symbols depended on by - -- the statement we are parsing - lbs <- liftIO $ runAction "eval: GetLinkables" st $ do - linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp - uses_ GetLinkable (filter (/= nfp) linkables_needed) -- We don't need the linkable for the current module - let hscEnv'' = hscEnv' { hsc_HPT = addListToHpt (hsc_HPT hscEnv') [(moduleName $ mi_module $ hm_iface hm, hm) | lb <- lbs, let hm = linkableHomeMod lb] } - + -- Perform the evaluation of the command edits <- perf "edits" $ liftIO $ - evalGhcEnv hscEnv'' $ - runTests - evalCfg - (st, fp) - tests + evalGhcEnv final_hscEnv $ do + runTests evalCfg (st, fp) tests let workspaceEditsMap = HashMap.fromList [(_uri, List $ addFinalReturn mdlText edits)] let workspaceEdits = WorkspaceEdit (Just workspaceEditsMap) Nothing Nothing @@ -350,6 +251,40 @@ runEvalCmd plId st EvalParams{..} = withIndefiniteProgress "Evaluating" Cancellable $ response' cmd +-- | Create an HscEnv which is suitable for performing interactive evaluation. +-- All necessary home modules will have linkables and the current module will +-- also be loaded into the environment. +-- +-- The interactive context and interactive dynamic flags are also set appropiately. +initialiseSessionForEval :: Bool -> IdeState -> NormalizedFilePath -> IO HscEnv +initialiseSessionForEval needs_quickcheck st nfp = do + (ms, env1) <- runAction "runEvalCmd" st $ do + + ms <- msrModSummary <$> use_ GetModSummary nfp + deps_hsc <- hscEnv <$> use_ GhcSessionDeps nfp + + linkables_needed <- reachableModules <$> use_ GetDependencyInformation nfp + linkables <- uses_ GetLinkable linkables_needed + let linkable_hsc = loadModulesHome (map linkableHomeMod linkables) deps_hsc + + -- unload old versions + keep_lbls <- currentLinkables + liftIO $ unload linkable_hsc $ map (\(mod, time) -> LM time mod []) $ moduleEnvToList keep_lbls + return (ms, linkable_hsc) + -- Bit awkward we need to use evalGhcEnv here but setContext requires to run + -- in the Ghc monad + env2 <- evalGhcEnv env1 $ do + setContext [Compat.IIModule (moduleName (ms_mod ms))] + let df = flip xopt_set LangExt.ExtendedDefaultRules + . flip xopt_unset LangExt.MonomorphismRestriction + $ (ms_hspp_opts ms) { + useColor = Never + , canUseColor = False } + modifyDynFlags (const df) + when needs_quickcheck $ void $ addPackages ["QuickCheck"] + getSession + return env2 + addFinalReturn :: Text -> [TextEdit] -> [TextEdit] addFinalReturn mdlText edits | not (null edits) && not (T.null mdlText) && T.last mdlText /= '\n' = @@ -379,6 +314,12 @@ testsBySection sections = ] type TEnv = (IdeState, String) +-- |GHC declarations required for expression evaluation +evalSetup :: Ghc () +evalSetup = do + preludeAsP <- parseImportDecl "import qualified Prelude as P" + context <- getContext + setContext (IIDecl preludeAsP : context) runTests :: EvalConfig -> TEnv -> [(Section, Test)] -> Ghc [TextEdit] runTests EvalConfig{..} e@(_st, _) tests = do @@ -392,7 +333,6 @@ runTests EvalConfig{..} e@(_st, _) tests = do processTest e@(st, fp) df (section, test) = do let dbg = logWith st let pad = pad_ $ (if isLiterate fp then ("> " `T.append`) else id) $ padPrefix (sectionFormat section) - rs <- runTest e df test dbg "TEST RESULTS" rs @@ -565,22 +505,6 @@ prettyWarn Warn{..} = T.unpack (printOutputable $ SrcLoc.getLoc warnMsg) <> ": warning:\n" <> " " <> SrcLoc.unLoc warnMsg -runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnv -runGetSession st nfp = liftIO $ runAction "eval" st $ do - -- Create a new GHC Session rather than reusing an existing one - -- to avoid interfering with ghcide - -- UPDATE: I suspect that this doesn't really work, we always get the same Session - -- we probably cache hscEnvs in the Session state - IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO - let fp = fromNormalizedFilePath nfp - ((_, res),_) <- liftIO $ loadSessionFun fp - let env = fromMaybe (error $ "Unknown file: " <> fp) res - ghcSessionDepsConfig = def - { checkForImportCycles = False - } - res <- fmap hscEnvWithImportPaths <$> ghcSessionDepsDefinition True ghcSessionDepsConfig env nfp - return $ fromMaybe (error $ "Unable to load file: " <> fp) res - needsQuickCheck :: [(Section, Test)] -> Bool needsQuickCheck = any (isProperty . snd) @@ -761,22 +685,3 @@ parseGhciLikeCmd input = do (':', rest) <- T.uncons $ T.stripStart input pure $ second T.strip $ T.break isSpace rest -setupDynFlagsForGHCiLike :: HscEnv -> DynFlags -> IO DynFlags -setupDynFlagsForGHCiLike env dflags = do - let dflags3 = setInterpreterLinkerOptions dflags - platform = targetPlatform dflags3 - evalWays = Compat.hostFullWays - dflags3a = setWays evalWays dflags3 - dflags3b = - foldl gopt_set dflags3a $ - concatMap (Compat.wayGeneralFlags platform) evalWays - dflags3c = - foldl gopt_unset dflags3b $ - concatMap (Compat.wayUnsetGeneralFlags platform) evalWays - dflags4 = - dflags3c - `gopt_set` Opt_ImplicitImportQualified - `gopt_set` Opt_IgnoreOptimChanges - `gopt_set` Opt_IgnoreHpcChanges - `gopt_unset` Opt_DiagnosticsShowCaret - Compat.hsc_dflags <$> Compat.initializePlugins (Compat.hscSetFlags dflags4 env)