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)