diff --git a/ghcide/.hlint.yaml b/ghcide/.hlint.yaml index 01f035184a..84cd0879a8 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 78af32e8ba..1e4f367140 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 a6da170c14..aa5a0e1b9f 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 13de867963..75d5870e24 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 6f8900b54e..5d98fd873b 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 23fa70d3df..1dc0c0f2a2 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 d36ad94bc8..61f8d82644 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 198a94c03b..0b1ff0f6c0 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 9e58cbd0f6..6f85af7678 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 a732fcd6fb..f35c45d526 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 881aed4406..14e861f38b 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 14fa2f6a8a..d021feea49 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 e37acde140..e3114e1656 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 41dea1bd48..ef9541eba0 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)