diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal index f13f3898ea..262b5844e1 100644 --- a/ghcide/ghcide.cabal +++ b/ghcide/ghcide.cabal @@ -151,6 +151,7 @@ library Development.IDE.Core.Shake Development.IDE.Core.Tracing Development.IDE.GHC.Compat + Development.IDE.Core.Compile Development.IDE.GHC.Error Development.IDE.GHC.ExactPrint Development.IDE.GHC.Orphans @@ -197,7 +198,6 @@ library other-modules: Development.IDE.Session.VersionCheck other-modules: - Development.IDE.Core.Compile Development.IDE.Core.FileExists Development.IDE.GHC.CPP Development.IDE.GHC.Warnings 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 24d7e89476..53c5197f65 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -36,13 +36,8 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except ( ExceptT (..), ) -import Data.Aeson - ( FromJSON, - ToJSON, - toJSON, - ) +import Data.Aeson (toJSON) import Data.Char (isSpace) -import Data.Either (isRight) import qualified Data.HashMap.Strict as HashMap import Data.List (dropWhileEnd, @@ -59,10 +54,10 @@ import qualified Data.Text as T import Data.Time (getCurrentTime) import Data.Typeable (Typeable) import Development.IDE - (realSrcSpanToRange, GetModSummary (..), + ( Action, + realSrcSpanToRange, GetModSummary (..), GetParsedModuleWithComments (..), - GhcSession (..), - HscEnvEq (envImportPaths), + HscEnvEq, IdeState, List (List), NormalizedFilePath, @@ -77,9 +72,15 @@ import Development.IDE toNormalizedUri, uriToFilePath', useWithStale_, - use_, prettyPrint + prettyPrint, + use_, useNoFile_, uses_, + GhcSessionIO(..), GetDependencies(..), GetModIface(..), + HiFileResult (hirHomeMod, hirModSummary) ) +import Development.IDE.Core.Rules (TransitiveDependencies(transitiveModuleDeps)) +import Development.IDE.Core.Compile (setupFinderCache, loadModulesHome) import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan, UnhelpfulSpan), srcSpanFile, GhcException, setInteractiveDynFlags) +import Development.IDE.Types.Options import DynamicLoading (initializePlugins) import FastString (unpackFS) import GHC @@ -109,16 +110,14 @@ import GHC load, runDecls, setContext, - setInteractiveDynFlags, setLogAction, setSessionDynFlags, setTargets, typeKind, ) -import GHC.Generics (Generic) -import qualified GHC.LanguageExtensions.Type as LangExt import GhcPlugins ( DynFlags (..), + hsc_dflags, defaultLogActionHPutStrDoc, gopt_set, gopt_unset, @@ -147,15 +146,14 @@ import Ide.Plugin.Eval.Code testRanges, ) import Ide.Plugin.Eval.GHC - ( addExtension, - addImport, + ( addImport, addPackages, hasPackage, isExpr, showDynFlags, ) import Ide.Plugin.Eval.Parse.Comments (commentsToSections) -import Ide.Plugin.Eval.Parse.Option (langOptions, parseSetFlags) +import Ide.Plugin.Eval.Parse.Option (parseSetFlags) import Ide.Plugin.Eval.Types import Ide.Plugin.Eval.Util ( asS, @@ -214,7 +212,6 @@ import Outputable import System.FilePath (takeFileName) import System.IO (hClose) import System.IO.Temp (withSystemTempFile) -import Text.Read (readMaybe) import Util (OverridingBool (Never)) import Development.IDE.Core.PositionMapping (toCurrentRange) import qualified Data.DList as DL @@ -344,14 +341,14 @@ runEvalCmd lsp st EvalParams{..} = (Just (textToStringBuffer mdlText, now)) -- Setup environment for evaluation - hscEnv' <- withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> ExceptT . (either Left id <$>) . gStrictTry . evalGhcEnv (hscEnvWithImportPaths session) $ do + hscEnv' <- withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> ExceptT . (either Left id <$>) . gStrictTry . evalGhcEnv session $ do env <- getSession -- Install the module pragmas and options df <- liftIO $ setupDynFlagsForGHCiLike env $ ms_hspp_opts ms - let impPaths = fromMaybe (importPaths df) (envImportPaths session) - -- Restore the cradle import paths + -- Restore the original import paths + let impPaths = importPaths $ hsc_dflags env df <- return df{importPaths = impPaths} -- Set the modified flags in the session @@ -640,14 +637,29 @@ prettyWarn Warn{..} = prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n" <> " " <> SrcLoc.unLoc warnMsg -runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnvEq -runGetSession st nfp = - liftIO $ - runAction "getSession" st $ - use_ - GhcSession - -- GhcSessionDeps - nfp +ghcSessionDepsDefinition :: HscEnvEq -> NormalizedFilePath -> Action HscEnv +ghcSessionDepsDefinition env file = do + let hsc = hscEnvWithImportPaths env + deps <- use_ GetDependencies file + let tdeps = transitiveModuleDeps deps + ifaces <- uses_ GetModIface tdeps + + -- Currently GetDependencies returns things in topological order so A comes before B if A imports B. + -- We need to reverse this as GHC gets very unhappy otherwise and complains about broken interfaces. + -- Long-term we might just want to change the order returned by GetDependencies + let inLoadOrder = reverse (map hirHomeMod ifaces) + + liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc + +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 + IdeGhcSession{loadSessionFun} <- useNoFile_ GhcSessionIO + let fp = fromNormalizedFilePath nfp + ((_, res),_) <- liftIO $ loadSessionFun fp + let hscEnv = fromMaybe (error $ "Unknown file: " <> fp) res + ghcSessionDepsDefinition hscEnv nfp needsQuickCheck :: [(Section, Test)] -> Bool needsQuickCheck = any (isProperty . snd) @@ -670,23 +682,6 @@ errorLines = . T.lines . T.pack -{- -Check that extensions actually exists. - ->>> ghcOptions ":set -XLambdaCase" -Right [LambdaCase] ->>> ghcOptions ":set -XLambdaCase -XNotRight" -Left "Unknown extension: \"NotRight\"" --} -ghcOptions :: [Char] -> Either String [LangExt.Extension] -ghcOptions = either Left (mapM chk) . langOptions - where - chk o = - maybe - (Left $ unwords ["Unknown extension:", show o]) - Right - (readMaybe o :: Maybe LangExt.Extension) - {- | >>> map (pad_ (T.pack "--")) (map T.pack ["2+2",""]) ["--2+2","--"]