From ab46fe8d06d8d9ee745592c57d92fc764e9d8995 Mon Sep 17 00:00:00 2001
From: Pepe Iborra <pepeiborra@gmail.com>
Date: Fri, 12 Nov 2021 10:23:37 +0000
Subject: [PATCH] Improve the performance of GetModIfaceFromDisk in large repos
and delete GetDependencies (#2323)
* Improve the performance of GetModIfaceFromDisk in large repos
There are three benefits:
1. GetModIfaceFromDisk and GhcSessionDeps no longer depend on the transitive module summaries. This means fewer edges in the build graph = smaller build graph = faster builds
2. Avoid duplicate computations in setting up the GHC session with the dependencies of the module. Previously the total work done was O(NlogN) in the number of transitive dependencies, now it is O(N).
3. Increased sharing of HPT and FinderCache. Ideally we should also
share the module graphs, but the datatype is abstract, doesn't have a
monoid instance, and cannot be coerced to something that has. We will
need to add the Monoid instance in GHC first.
On the Sigma repo:
- the startup metric goes down by ~34%.
- The edit metric also goes down by 15%.
- Max residency is down by 30% in the edit benchmark.
* format importes
* clean up
* remove stale comment
* fix build in GHC 9
* clean up
* Unify defintions of ghcSessionDeps
* mark test as no longer failing
* Prevent duplicate missing module diagnostics
* delete GetDependencies
* add a test for deeply nested import cycles
* Fix build in GHC 9.0
* bump ghcide version
* Introduce config options for the main rules
Surfacing the performance tradeoffs in the core build rules
* Avoid using the Monoid instance (removed in 9.4 ?????)
* Fix build with GHC 9
* Fix Eval plugin
---
ghcide/.hlint.yaml | 2 +-
ghcide/exe/Main.hs | 3 +-
ghcide/ghcide.cabal | 2 +-
ghcide/src/Development/IDE/Core/Compile.hs | 31 ++++-
ghcide/src/Development/IDE/Core/RuleTypes.hs | 10 +-
ghcide/src/Development/IDE/Core/Rules.hs | 124 ++++++++++--------
.../src/Development/IDE/GHC/Compat/Units.hs | 2 +
ghcide/src/Development/IDE/GHC/Compat/Util.hs | 5 +
.../IDE/Import/DependencyInformation.hs | 1 +
ghcide/src/Development/IDE/Main.hs | 2 +-
ghcide/src/Development/IDE/Plugin/Test.hs | 1 -
ghcide/test/exe/Main.hs | 41 ++++--
plugins/hls-eval-plugin/hls-eval-plugin.cabal | 3 +-
.../src/Ide/Plugin/Eval/CodeLens.hs | 49 +++----
14 files changed, 163 insertions(+), 113 deletions(-)
diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml
index 01f03518..84cd0879 100644
--- a/ghcide/.hlint.yaml
+++ b/ghcide/.hlint.yaml
@@ -133,7 +133,7 @@
# Things that are unsafe in Haskell base library
- {name: unsafeInterleaveIO, within: [Development.IDE.LSP.LanguageServer]}
- {name: unsafeDupablePerformIO, within: []}
- - {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code, Development.IDE.Types.Shake]}
+ - {name: unsafeCoerce, within: [Ide.Plugin.Eval.Code, Development.IDE.Core.Compile, Development.IDE.Types.Shake]}
# Things that are a bit dangerous in the GHC API
- {name: nameModule, within: []}
diff --git a/ghcide/exe/Main.hs b/ghcide/exe/Main.hs
index 78af32e8..1e4f3671 100644
--- a/ghcide/exe/Main.hs
+++ b/ghcide/exe/Main.hs
@@ -8,6 +8,7 @@ module Main(main) where
import Arguments (Arguments (..),
getArguments)
import Control.Monad.Extra (unless, whenJust)
+import Data.Default (def)
import Data.Version (showVersion)
import Development.GitRev (gitHash)
import Development.IDE (Priority (Debug, Info),
@@ -60,7 +61,7 @@ main = withTelemetryLogger $ \telemetryLogger -> do
,Main.argsRules = do
-- install the main and ghcide-plugin rules
- mainRule
+ mainRule def
-- install the kick action, which triggers a typecheck on every
-- Shake database restart, i.e. on every user edit.
unless argsDisableKick $
diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
index a6da170c..aa5a0e1b 100644
--- a/ghcide/ghcide.cabal
+++ b/ghcide/ghcide.cabal
@@ -2,7 +2,7 @@ cabal-version: 2.4
build-type: Simple
category: Development
name: ghcide
-version: 1.4.2.3
+version: 1.4.2.4
license: Apache-2.0
license-file: LICENSE
author: Digital Asset and Ghcide contributors
diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/ghcide/src/Development/IDE/Core/Compile.hs
index 13de8679..75d5870e 100644
--- a/ghcide/src/Development/IDE/Core/Compile.hs
+++ b/ghcide/src/Development/IDE/Core/Compile.hs
@@ -30,7 +30,7 @@ module Development.IDE.Core.Compile
, setupFinderCache
, getDocsBatch
, lookupName
- ) where
+ ,mergeEnvs) where
import Development.IDE.Core.Preprocessor
import Development.IDE.Core.RuleTypes
@@ -89,8 +89,10 @@ import System.Directory
import System.FilePath
import System.IO.Extra (fixIO, newTempFileWithin)
+-- GHC API imports
-- GHC API imports
import GHC (GetDocsFailure (..),
+ mgModSummaries,
parsedSource)
import Control.Concurrent.Extra
@@ -100,11 +102,14 @@ import Data.Binary
import Data.Coerce
import Data.Functor
import qualified Data.HashMap.Strict as HashMap
+import Data.Map (Map)
import Data.Tuple.Extra (dupe)
import Data.Unique as Unique
import Development.IDE.Core.Tracing (withTrace)
+import Development.IDE.GHC.Compat.Util (emptyUDFM, plusUDFM)
import qualified Language.LSP.Server as LSP
import qualified Language.LSP.Types as LSP
+import Unsafe.Coerce
-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
parseModule
@@ -686,6 +691,30 @@ loadModulesHome mod_infos e =
where
mod_name = moduleName . mi_module . hm_iface
+-- Merge the HPTs, module graphs and FinderCaches
+mergeEnvs :: HscEnv -> [ModSummary] -> [HomeModInfo] -> [HscEnv] -> IO HscEnv
+mergeEnvs env extraModSummaries extraMods envs = do
+ prevFinderCache <- concatFC <$> mapM (readIORef . hsc_FC) envs
+ let ims = map (Compat.installedModule (homeUnitId_ $ hsc_dflags env) . moduleName . ms_mod) extraModSummaries
+ ifrs = zipWith (\ms -> InstalledFound (ms_location ms)) extraModSummaries ims
+ newFinderCache <- newIORef $
+ foldl'
+ (\fc (im, ifr) -> Compat.extendInstalledModuleEnv fc im ifr) prevFinderCache
+ $ zip ims ifrs
+ return $ loadModulesHome extraMods $ env{
+ hsc_HPT = foldMapBy plusUDFM emptyUDFM hsc_HPT envs,
+ hsc_FC = newFinderCache,
+ hsc_mod_graph = mkModuleGraph $ extraModSummaries ++ nubOrdOn ms_mod (concatMap (mgModSummaries . hsc_mod_graph) envs)
+ }
+ where
+ -- required because 'FinderCache':
+ -- 1) doesn't have a 'Monoid' instance,
+ -- 2) is abstract and doesn't export constructors
+ -- To work around this, we coerce to the underlying type
+ -- To remove this, I plan to upstream the missing Monoid instance
+ concatFC :: [FinderCache] -> FinderCache
+ concatFC = unsafeCoerce (mconcat @(Map InstalledModule InstalledFindResult))
+
withBootSuffix :: HscSource -> ModLocation -> ModLocation
withBootSuffix HsBootFile = addBootSuffixLocnOut
withBootSuffix _ = id
diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs
index 6f8900b5..5d98fd87 100644
--- a/ghcide/src/Development/IDE/Core/RuleTypes.hs
+++ b/ghcide/src/Development/IDE/Core/RuleTypes.hs
@@ -73,10 +73,6 @@ type instance RuleResult GetParsedModuleWithComments = ParsedModule
-- a module could not be parsed or an import cycle.
type instance RuleResult GetDependencyInformation = DependencyInformation
--- | Transitive module and pkg dependencies based on the information produced by GetDependencyInformation.
--- This rule is also responsible for calling ReportImportCycles for each file in the transitive closure.
-type instance RuleResult GetDependencies = TransitiveDependencies
-
type instance RuleResult GetModuleGraph = DependencyInformation
data GetKnownTargets = GetKnownTargets
@@ -234,6 +230,7 @@ type instance RuleResult GetDocMap = DocAndKindMap
type instance RuleResult GhcSession = HscEnvEq
-- | A GHC session preloaded with all the dependencies
+-- This rule is also responsible for calling ReportImportCycles for the direct dependencies
type instance RuleResult GhcSessionDeps = HscEnvEq
-- | Resolve the imports in a module to the file path of a module in the same package
@@ -389,11 +386,6 @@ data ReportImportCycles = ReportImportCycles
instance Hashable ReportImportCycles
instance NFData ReportImportCycles
-data GetDependencies = GetDependencies
- deriving (Eq, Show, Typeable, Generic)
-instance Hashable GetDependencies
-instance NFData GetDependencies
-
data TypeCheck = TypeCheck
deriving (Eq, Show, Typeable, Generic)
instance Hashable TypeCheck
diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs
index 23fa70d3..1dc0c0f2 100644
--- a/ghcide/src/Development/IDE/Core/Rules.hs
+++ b/ghcide/src/Development/IDE/Core/Rules.hs
@@ -11,7 +11,7 @@
--
module Development.IDE.Core.Rules(
-- * Types
- IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
+ IdeState, GetParsedModule(..), TransitiveDependencies(..),
Priority(..), GhcSessionIO(..), GetClientSettings(..),
-- * Functions
priorityTypeCheck,
@@ -22,6 +22,7 @@ module Development.IDE.Core.Rules(
defineNoFile,
defineEarlyCutOffNoFile,
mainRule,
+ RulesConfig(..),
getDependencies,
getParsedModule,
getParsedModuleWithComments,
@@ -35,7 +36,6 @@ module Development.IDE.Core.Rules(
getLocatedImportsRule,
getDependencyInformationRule,
reportImportCyclesRule,
- getDependenciesRule,
typeCheckRule,
getDocMapRule,
loadGhcSession,
@@ -57,6 +57,7 @@ module Development.IDE.Core.Rules(
ghcSessionDepsDefinition,
getParsedModuleDefinition,
typeCheckRuleDefinition,
+ GhcSessionDepsConfig(..),
) where
#if !MIN_VERSION_ghc(8,8,0)
@@ -139,8 +140,7 @@ import qualified Language.LSP.Server as LSP
import Language.LSP.Types (SMethod (SCustomMethod))
import Language.LSP.VFS
import System.Directory (canonicalizePath, makeAbsolute)
-
-import Data.Default (def)
+import Data.Default (def, Default)
import Ide.Plugin.Properties (HasProperty,
KeyNameProxy,
Properties,
@@ -149,7 +149,6 @@ import Ide.Plugin.Properties (HasProperty,
import Ide.PluginUtils (configForPlugin)
import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser),
PluginId)
-import qualified Data.HashSet as HS
-- | This is useful for rules to convert rules that can only produce errors or
-- a result into the more general IdeResult type that supports producing
@@ -163,7 +162,8 @@ toIdeResult = either (, Nothing) (([],) . Just)
-- | Get all transitive file dependencies of a given module.
-- Does not include the file itself.
getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
-getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
+getDependencies file =
+ fmap transitiveModuleDeps . (`transitiveDeps` file) <$> use_ GetDependencyInformation file
getSourceFileSource :: NormalizedFilePath -> Action BS.ByteString
getSourceFileSource nfp = do
@@ -334,7 +334,7 @@ getLocatedImportsRule =
return $ if itExists then Just nfp' else Nothing
| Just tt <- HM.lookup (TargetModule modName) targets = do
-- reuse the existing NormalizedFilePath in order to maximize sharing
- let ttmap = HM.mapWithKey const (HS.toMap tt)
+ let ttmap = HM.mapWithKey const (HashSet.toMap tt)
nfp' = HM.lookupDefault nfp nfp ttmap
itExists <- getFileExists nfp'
return $ if itExists then Just nfp' else Nothing
@@ -492,18 +492,6 @@ reportImportCyclesRule =
pure (moduleNameString . moduleName . ms_mod $ ms)
showCycle mods = T.intercalate ", " (map T.pack mods)
--- returns all transitive dependencies in topological order.
--- NOTE: result does not include the argument file.
-getDependenciesRule :: Rules ()
-getDependenciesRule =
- defineEarlyCutoff $ RuleNoDiagnostics $ \GetDependencies file -> do
- depInfo <- use_ GetDependencyInformation file
- let allFiles = reachableModules depInfo
- _ <- uses_ ReportImportCycles allFiles
- opts <- getIdeOptions
- let mbFingerprints = map (Util.fingerprintString . fromNormalizedFilePath) allFiles <$ optShakeFiles opts
- return (fingerprintToBS . Util.fingerprintFingerprints <$> mbFingerprints, transitiveDeps depInfo file)
-
getHieAstsRule :: Rules ()
getHieAstsRule =
define $ \GetHieAst f -> do
@@ -654,8 +642,8 @@ currentLinkables = do
where
go (mod, time) = LM time mod []
-loadGhcSession :: Rules ()
-loadGhcSession = do
+loadGhcSession :: GhcSessionDepsConfig -> Rules ()
+loadGhcSession ghcSessionDepsConfig = do
-- This function should always be rerun because it tracks changes
-- to the version of the collection of HscEnv's.
defineEarlyCutOffNoFile $ \GhcSessionIO -> do
@@ -691,49 +679,65 @@ loadGhcSession = do
Nothing -> LBS.toStrict $ B.encode (hash (snd val))
return (Just cutoffHash, val)
- define $ \GhcSessionDeps file -> ghcSessionDepsDefinition file
-
-ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)
-ghcSessionDepsDefinition file = do
+ defineNoDiagnostics $ \GhcSessionDeps file -> do
env <- use_ GhcSession file
- let hsc = hscEnv env
- ms <- msrModSummary <$> use_ GetModSummaryWithoutTimestamps file
- deps <- use_ GetDependencies file
- let tdeps = transitiveModuleDeps deps
- uses_th_qq =
- xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
- dflags = ms_hspp_opts ms
- ifaces <- if uses_th_qq
- then uses_ GetModIface tdeps
- else uses_ GetModIfaceWithoutLinkable 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)
-
- session' <- liftIO $ loadModulesHome inLoadOrder <$> setupFinderCache (map hirModSummary ifaces) hsc
-
- res <- liftIO $ newHscEnvEqWithImportPaths (envImportPaths env) session' []
- return ([], Just res)
+ ghcSessionDepsDefinition ghcSessionDepsConfig env file
+
+data GhcSessionDepsConfig = GhcSessionDepsConfig
+ { checkForImportCycles :: Bool
+ , forceLinkables :: Bool
+ , fullModSummary :: Bool
+ }
+instance Default GhcSessionDepsConfig where
+ def = GhcSessionDepsConfig
+ { checkForImportCycles = True
+ , forceLinkables = False
+ , fullModSummary = False
+ }
+
+ghcSessionDepsDefinition :: GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq)
+ghcSessionDepsDefinition GhcSessionDepsConfig{..} env file = do
+ let hsc = hscEnv env
+
+ mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file
+ case mbdeps of
+ Nothing -> return Nothing
+ Just deps -> do
+ when checkForImportCycles $ void $ uses_ ReportImportCycles deps
+ ms:mss <- map msrModSummary <$> if fullModSummary
+ then uses_ GetModSummary (file:deps)
+ else uses_ GetModSummaryWithoutTimestamps (file:deps)
+
+ depSessions <- map hscEnv <$> uses_ GhcSessionDeps deps
+ let uses_th_qq =
+ xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
+ dflags = ms_hspp_opts ms
+ ifaces <- if uses_th_qq || forceLinkables
+ then uses_ GetModIface deps
+ else uses_ GetModIfaceWithoutLinkable deps
+
+ let inLoadOrder = map hirHomeMod ifaces
+ session' <- liftIO $ mergeEnvs hsc mss inLoadOrder depSessions
+
+ Just <$> liftIO (newHscEnvEqWithImportPaths (envImportPaths env) session' [])
-- | Load a iface from disk, or generate it if there isn't one or it is out of date
-- This rule also ensures that the `.hie` and `.o` (if needed) files are written out.
getModIfaceFromDiskRule :: Rules ()
getModIfaceFromDiskRule = defineEarlyCutoff $ Rule $ \GetModIfaceFromDisk f -> do
ms <- msrModSummary <$> use_ GetModSummary f
- (diags_session, mb_session) <- ghcSessionDepsDefinition f
+ mb_session <- use GhcSessionDeps f
case mb_session of
- Nothing -> return (Nothing, (diags_session, Nothing))
+ Nothing -> return (Nothing, ([], Nothing))
Just session -> do
sourceModified <- use_ IsHiFileStable f
linkableType <- getLinkableType f
r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms)
case r of
- (diags, Nothing) -> return (Nothing, (diags ++ diags_session, Nothing))
+ (diags, Nothing) -> return (Nothing, (diags, Nothing))
(diags, Just x) -> do
let !fp = Just $! hiFileFingerPrint x
- return (fp, (diags <> diags_session, Just x))
+ return (fp, (diags, Just x))
-- | Check state of hiedb after loading an iface from disk - have we indexed the corresponding `.hie` file?
-- This function is responsible for ensuring database consistency
@@ -1055,9 +1059,18 @@ writeHiFileAction hsc hiFile = do
resetInterfaceStore extras $ toNormalizedFilePath' targetPath
writeHiFile hsc hiFile
+data RulesConfig = RulesConfig
+ { -- | Disable import cycle checking for improved performance in large codebases
+ checkForImportCycles :: Bool
+ -- | Disable TH for improved performance in large codebases
+ , enableTemplateHaskell :: Bool
+ }
+
+instance Default RulesConfig where def = RulesConfig True True
+
-- | A rule that wires per-file rules together
-mainRule :: Rules ()
-mainRule = do
+mainRule :: RulesConfig -> Rules ()
+mainRule RulesConfig{..} = do
linkables <- liftIO $ newVar emptyModuleEnv
addIdeGlobal $ CompiledLinkables linkables
getParsedModuleRule
@@ -1065,10 +1078,9 @@ mainRule = do
getLocatedImportsRule
getDependencyInformationRule
reportImportCyclesRule
- getDependenciesRule
typeCheckRule
getDocMapRule
- loadGhcSession
+ loadGhcSession def{checkForImportCycles}
getModIfaceFromDiskRule
getModIfaceFromDiskAndIndexRule
getModIfaceRule
@@ -1086,8 +1098,10 @@ mainRule = do
-- * ObjectLinkable -> BCOLinkable : the prev linkable can be reused, signal "no change"
-- * Object/BCO -> NoLinkable : the prev linkable can be ignored, signal "no change"
-- * otherwise : the prev linkable cannot be reused, signal "value has changed"
- defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file ->
- needsCompilationRule file
+ if enableTemplateHaskell
+ then defineEarlyCutoff $ RuleWithCustomNewnessCheck (<=) $ \NeedsCompilation file ->
+ needsCompilationRule file
+ else defineNoDiagnostics $ \NeedsCompilation _ -> return $ Just Nothing
generateCoreRule
getImportMapRule
getAnnotatedParsedSourceRule
diff --git a/ghcide/src/Development/IDE/GHC/Compat/Units.hs b/ghcide/src/Development/IDE/GHC/Compat/Units.hs
index d36ad94b..61f8d826 100644
--- a/ghcide/src/Development/IDE/GHC/Compat/Units.hs
+++ b/ghcide/src/Development/IDE/GHC/Compat/Units.hs
@@ -45,6 +45,7 @@ module Development.IDE.GHC.Compat.Units (
ExternalPackageState(..),
-- * Utils
filterInplaceUnits,
+ FinderCache,
) where
#if MIN_VERSION_ghc(9,0,0)
@@ -53,6 +54,7 @@ import qualified GHC.Data.ShortText as ST
import GHC.Driver.Env (hsc_unit_dbs)
import GHC.Unit.Env
import GHC.Unit.External
+import GHC.Unit.Finder
#else
import GHC.Driver.Types
#endif
diff --git a/ghcide/src/Development/IDE/GHC/Compat/Util.hs b/ghcide/src/Development/IDE/GHC/Compat/Util.hs
index 198a94c0..0b1ff0f6 100644
--- a/ghcide/src/Development/IDE/GHC/Compat/Util.hs
+++ b/ghcide/src/Development/IDE/GHC/Compat/Util.hs
@@ -59,6 +59,9 @@ module Development.IDE.GHC.Compat.Util (
Unique,
mkUnique,
newTagUnique,
+ -- * UniqDFM
+ emptyUDFM,
+ plusUDFM,
-- * String Buffer
StringBuffer(..),
hGetStringBuffer,
@@ -76,6 +79,7 @@ import GHC.Data.Maybe
import GHC.Data.Pair
import GHC.Data.StringBuffer
import GHC.Types.Unique
+import GHC.Types.Unique.DFM
import GHC.Utils.Fingerprint
import GHC.Utils.Misc
import GHC.Utils.Outputable (pprHsString)
@@ -94,6 +98,7 @@ import Pair
import Outputable (pprHsString)
import Panic hiding (try)
import StringBuffer
+import UniqDFM
import Unique
import Util
#endif
diff --git a/ghcide/src/Development/IDE/Import/DependencyInformation.hs b/ghcide/src/Development/IDE/Import/DependencyInformation.hs
index 9e58cbd0..6f85af76 100644
--- a/ghcide/src/Development/IDE/Import/DependencyInformation.hs
+++ b/ghcide/src/Development/IDE/Import/DependencyInformation.hs
@@ -327,6 +327,7 @@ immediateReverseDependencies file DependencyInformation{..} = do
FilePathId cur_id <- lookupPathToId depPathIdMap file
return $ map (idToPath depPathIdMap . FilePathId) (maybe mempty IntSet.toList (IntMap.lookup cur_id depReverseModuleDeps))
+-- | returns all transitive dependencies in topological order.
transitiveDeps :: DependencyInformation -> NormalizedFilePath -> Maybe TransitiveDependencies
transitiveDeps DependencyInformation{..} file = do
let !fileId = pathToId depPathIdMap file
diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs
index a732fcd6..f35c45d5 100644
--- a/ghcide/src/Development/IDE/Main.hs
+++ b/ghcide/src/Development/IDE/Main.hs
@@ -187,7 +187,7 @@ defaultArguments priority = Arguments
{ argsOTMemoryProfiling = False
, argCommand = LSP
, argsLogger = stderrLogger priority
- , argsRules = mainRule >> action kick
+ , argsRules = mainRule def >> action kick
, argsGhcidePlugin = mempty
, argsHlsPlugins = pluginDescToIdePlugins Ghcide.descriptors
, argsSessionLoadingOptions = def
diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs
index 881aed44..14e861f3 100644
--- a/ghcide/src/Development/IDE/Plugin/Test.hs
+++ b/ghcide/src/Development/IDE/Plugin/Test.hs
@@ -150,7 +150,6 @@ parseAction "getparsedmodule" fp = Right . isJust <$> use GetParsedModule fp
parseAction "ghcsession" fp = Right . isJust <$> use GhcSession fp
parseAction "ghcsessiondeps" fp = Right . isJust <$> use GhcSessionDeps fp
parseAction "gethieast" fp = Right . isJust <$> use GetHieAst fp
-parseAction "getDependencies" fp = Right . isJust <$> use GetDependencies fp
parseAction "getFileContents" fp = Right . isJust <$> use GetFileContents fp
parseAction other _ = return $ Left $ "Cannot parse ide rule: " <> pack (original other)
diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs
index 14fa2f6a..d021feea 100644
--- a/ghcide/test/exe/Main.hs
+++ b/ghcide/test/exe/Main.hs
@@ -410,6 +410,30 @@ diagnosticTests = testGroup "diagnostics"
, [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
)
]
+ , testSession' "deeply nested cyclic module dependency" $ \path -> do
+ let contentA = unlines
+ [ "module ModuleA where" , "import ModuleB" ]
+ let contentB = unlines
+ [ "module ModuleB where" , "import ModuleA" ]
+ let contentC = unlines
+ [ "module ModuleC where" , "import ModuleB" ]
+ let contentD = T.unlines
+ [ "module ModuleD where" , "import ModuleC" ]
+ cradle =
+ "cradle: {direct: {arguments: [ModuleA, ModuleB, ModuleC, ModuleD]}}"
+ liftIO $ writeFile (path </> "ModuleA.hs") contentA
+ liftIO $ writeFile (path </> "ModuleB.hs") contentB
+ liftIO $ writeFile (path </> "ModuleC.hs") contentC
+ liftIO $ writeFile (path </> "hie.yaml") cradle
+ _ <- createDoc "ModuleD.hs" "haskell" contentD
+ expectDiagnostics
+ [ ( "ModuleA.hs"
+ , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
+ )
+ , ( "ModuleB.hs"
+ , [(DsError, (1, 7), "Cyclic module dependency between ModuleA, ModuleB")]
+ )
+ ]
, testSessionWait "cyclic module dependency with hs-boot" $ do
let contentA = T.unlines
[ "module ModuleA where"
@@ -669,9 +693,9 @@ diagnosticTests = testGroup "diagnostics"
expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]
, testGroup "Cancellation"
- [ cancellationTestGroup "edit header" editHeader yesDepends yesSession noParse noTc
- , cancellationTestGroup "edit import" editImport noDepends noSession yesParse noTc
- , cancellationTestGroup "edit body" editBody yesDepends yesSession yesParse yesTc
+ [ cancellationTestGroup "edit header" editHeader yesSession noParse noTc
+ , cancellationTestGroup "edit import" editImport noSession yesParse noTc
+ , cancellationTestGroup "edit body" editBody yesSession yesParse yesTc
]
]
where
@@ -685,17 +709,14 @@ diagnosticTests = testGroup "diagnostics"
noParse = False
yesParse = True
- noDepends = False
- yesDepends = True
-
noSession = False
yesSession = True
noTc = False
yesTc = True
-cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> Bool -> TestTree
-cancellationTestGroup name edits dependsOutcome sessionDepsOutcome parseOutcome tcOutcome = testGroup name
+cancellationTestGroup :: TestName -> (TextDocumentContentChangeEvent, TextDocumentContentChangeEvent) -> Bool -> Bool -> Bool -> TestTree
+cancellationTestGroup name edits sessionDepsOutcome parseOutcome tcOutcome = testGroup name
[ cancellationTemplate edits Nothing
, cancellationTemplate edits $ Just ("GetFileContents", True)
, cancellationTemplate edits $ Just ("GhcSession", True)
@@ -704,7 +725,6 @@ cancellationTestGroup name edits dependsOutcome sessionDepsOutcome parseOutcome
, cancellationTemplate edits $ Just ("GetModSummaryWithoutTimestamps", True)
-- getLocatedImports never fails
, cancellationTemplate edits $ Just ("GetLocatedImports", True)
- , cancellationTemplate edits $ Just ("GetDependencies", dependsOutcome)
, cancellationTemplate edits $ Just ("GhcSessionDeps", sessionDepsOutcome)
, cancellationTemplate edits $ Just ("GetParsedModule", parseOutcome)
, cancellationTemplate edits $ Just ("TypeCheck", tcOutcome)
@@ -3843,9 +3863,6 @@ checkFileCompiles fp diag =
pluginSimpleTests :: TestTree
pluginSimpleTests =
ignoreInWindowsForGHC88And810 $
-#if __GLASGOW_HASKELL__ == 810 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 5
- expectFailBecause "known broken for ghc 8.10.5 (see GHC #19763)" $
-#endif
testSessionWithExtraFiles "plugin-knownnat" "simple plugin" $ \dir -> do
_ <- openDoc (dir </> "KnownNat.hs") "haskell"
liftIO $ writeFile (dir</>"hie.yaml")
diff --git a/plugins/hls-eval-plugin/hls-eval-plugin.cabal b/plugins/hls-eval-plugin/hls-eval-plugin.cabal
index e37acde1..e3114e16 100644
--- a/plugins/hls-eval-plugin/hls-eval-plugin.cabal
+++ b/plugins/hls-eval-plugin/hls-eval-plugin.cabal
@@ -55,6 +55,7 @@ library
, aeson
, base >=4.12 && <5
, containers
+ , data-default
, deepseq
, Diff ^>=0.4.0
, directory
@@ -64,7 +65,7 @@ library
, ghc
, ghc-boot-th
, ghc-paths
- , ghcide >=1.2 && <1.5
+ , ghcide >=1.4.2.4 && <1.5
, hashable
, hls-graph
, hls-plugin-api ^>=1.2
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 41dea1bd..ef9541eb 100644
--- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs
+++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs
@@ -27,7 +27,7 @@ module Ide.Plugin.Eval.CodeLens (
import Control.Applicative (Alternative ((<|>)))
import Control.Arrow (second, (>>>))
-import Control.Exception (assert, try)
+import Control.Exception (try)
import qualified Control.Exception as E
import Control.Lens (_1, _3, (%~), (<&>), (^.))
import Control.Monad (guard, join, void, when)
@@ -35,33 +35,29 @@ import Control.Monad.IO.Class (MonadIO (liftIO))
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, isJust)
+import Data.Maybe (catMaybes, fromMaybe)
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 (Action, GetDependencies (..),
- GetModIface (..),
- GetModSummary (..),
- GhcSessionIO (..),
- HiFileResult (hirHomeMod, hirModSummary),
- HscEnvEq, IdeState,
+import Development.IDE (GetModSummary (..),
+ GhcSessionIO (..), IdeState,
ModSummaryResult (..),
NeedsCompilation (NeedsCompilation),
- evalGhcEnv,
+ evalGhcEnv, hscEnv,
hscEnvWithImportPaths,
prettyPrint, runAction,
textToStringBuffer,
toNormalizedFilePath',
uriToFilePath', useNoFile_,
- useWithStale_, use_, uses_)
-import Development.IDE.Core.Compile (loadModulesHome,
- setupFinderCache)
-import Development.IDE.Core.Rules (TransitiveDependencies (transitiveModuleDeps))
+ useWithStale_, use_)
+import Development.IDE.Core.Rules (GhcSessionDepsConfig (..),
+ ghcSessionDepsDefinition)
import Development.IDE.GHC.Compat hiding (typeKind, unitState)
import qualified Development.IDE.GHC.Compat as Compat
import qualified Development.IDE.GHC.Compat as SrcLoc
@@ -533,30 +529,23 @@ prettyWarn Warn{..} =
prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n"
<> " " <> SrcLoc.unLoc warnMsg
-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
- liftIO $ assert (all (isJust . hm_linkable . hirHomeMod) ifaces) $ pure ()
-
- -- 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
+ -- 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 hscEnv = fromMaybe (error $ "Unknown file: " <> fp) res
- ghcSessionDepsDefinition hscEnv nfp
+ let env = fromMaybe (error $ "Unknown file: " <> fp) res
+ ghcSessionDepsConfig = def
+ { forceLinkables = True
+ , checkForImportCycles = False
+ , fullModSummary = True
+ }
+ res <- fmap hscEnvWithImportPaths <$> ghcSessionDepsDefinition ghcSessionDepsConfig env nfp
+ return $ fromMaybe (error $ "Unable to load file: " <> fp) res
needsQuickCheck :: [(Section, Test)] -> Bool
needsQuickCheck = any (isProperty . snd)
--
GitLab