From 8780066469057f6549a9c81d78d37c959cdf661d Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sun, 14 Feb 2021 17:21:53 +0800 Subject: [PATCH 1/3] Catch GHC errors in listing module names --- .../src/Development/IDE/Plugin/Completions.hs | 4 ++-- .../IDE/Plugin/Completions/Logic.hs | 22 ++++++++++++++----- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index ee1d61fa7f..63412f36cd 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -36,6 +36,7 @@ import Ide.PluginUtils (getClientConfig) import Ide.Types import TcRnDriver (tcRnImportDecls) import Control.Concurrent.Async (concurrently) +import Data.Bifunctor (second) #if defined(GHC_LIB) import Development.IDE.Import.DependencyInformation #endif @@ -81,8 +82,7 @@ produceCompletions = do case (global, inScope) of ((_, Just globalEnv), (_, Just inScopeEnv)) -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file - cdata <- liftIO $ cacheDataProducer uri env (ms_mod ms) globalEnv inScopeEnv imps parsedDeps - return ([], Just cdata) + second Just <$> liftIO (cacheDataProducer uri env (ms_mod ms) globalEnv inScopeEnv imps parsedDeps) (_diag, _) -> return ([], Nothing) _ -> return ([], Nothing) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 4a4990be8f..7e3f831cc8 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -59,6 +59,9 @@ import Data.Functor import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), PluginId, WithSnippets (..)) import Control.Monad +import Control.Exception (evaluate) +import Control.DeepSeq (force) +import Development.IDE.Types.Diagnostics (FileDiagnostic) -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -294,7 +297,7 @@ mkPragmaCompl label insertText = Nothing Nothing Nothing Nothing Nothing -cacheDataProducer :: Uri -> HscEnv -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions +cacheDataProducer :: Uri -> HscEnv -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO ([FileDiagnostic], CachedCompletions) cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = do let dflags = hsc_dflags packageState curModName = moduleName curMod @@ -309,9 +312,6 @@ cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = d -- Full canonical names of imported modules importDeclerations = map unLoc limports - -- The list of all importable Modules from all packages - moduleNames = map showModName (listVisibleModuleNames dflags) - -- The given namespaces for the imported modules (ie. full name, or alias if used) allModNamesAsNS = map (showModName . asNamespace) importDeclerations @@ -364,14 +364,24 @@ cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = d return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp' : recordCompls + -- The list of all importable Modules from all packages + (lvmnDiags, moduleNames) <- + catchSrcErrors + dflags + "listVisibleModuleNames" + (evaluate . force $ map showModName (listVisibleModuleNames dflags)) + <&> \case + Left diags -> (diags, []) + Right x -> ([], x) + (unquals,quals) <- getCompls rdrElts - return $ CC + return (lvmnDiags, CC { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals , qualCompls = quals , importableModules = moduleNames - } + }) -- | Produces completions from the top level declarations of a module. localCompletionsForParsedModule :: Uri -> ParsedModule -> CachedCompletions From 29acc1b8afd9d6cfc83c22d8034af796b0f7d906 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sun, 14 Feb 2021 18:48:31 +0800 Subject: [PATCH 2/3] Move visible module names to HscEnvEq --- .../src/Development/IDE/Plugin/Completions.hs | 4 +-- .../IDE/Plugin/Completions/Logic.hs | 29 +++++++------------ ghcide/src/Development/IDE/Types/HscEnvEq.hs | 26 +++++++++++++---- 3 files changed, 33 insertions(+), 26 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions.hs b/ghcide/src/Development/IDE/Plugin/Completions.hs index 63412f36cd..893d344309 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions.hs @@ -36,7 +36,6 @@ import Ide.PluginUtils (getClientConfig) import Ide.Types import TcRnDriver (tcRnImportDecls) import Control.Concurrent.Async (concurrently) -import Data.Bifunctor (second) #if defined(GHC_LIB) import Development.IDE.Import.DependencyInformation #endif @@ -82,7 +81,8 @@ produceCompletions = do case (global, inScope) of ((_, Just globalEnv), (_, Just inScopeEnv)) -> do let uri = fromNormalizedUri $ normalizedFilePathToUri file - second Just <$> liftIO (cacheDataProducer uri env (ms_mod ms) globalEnv inScopeEnv imps parsedDeps) + cdata <- liftIO $ cacheDataProducer uri sess (ms_mod ms) globalEnv inScopeEnv imps parsedDeps + return ([], Just cdata) (_diag, _) -> return ([], Nothing) _ -> return ([], Nothing) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index 7e3f831cc8..d513a090e8 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -27,7 +27,6 @@ import HscTypes import Name import RdrName import Type -import Packages #if MIN_GHC_API_VERSION(8,10,0) import Predicate (isDictTy) import Pair @@ -59,9 +58,7 @@ import Data.Functor import Ide.PluginUtils (mkLspCommand) import Ide.Types (CommandId (..), PluginId, WithSnippets (..)) import Control.Monad -import Control.Exception (evaluate) -import Control.DeepSeq (force) -import Development.IDE.Types.Diagnostics (FileDiagnostic) +import Development.IDE.Types.HscEnvEq -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs @@ -297,9 +294,10 @@ mkPragmaCompl label insertText = Nothing Nothing Nothing Nothing Nothing -cacheDataProducer :: Uri -> HscEnv -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO ([FileDiagnostic], CachedCompletions) -cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = do - let dflags = hsc_dflags packageState +cacheDataProducer :: Uri -> HscEnvEq -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO CachedCompletions +cacheDataProducer uri env curMod globalEnv inScopeEnv limports deps = do + let + packageState = hscEnv env curModName = moduleName curMod importMap = Map.fromList [ (getLoc imp, imp) | imp <- limports ] @@ -312,6 +310,9 @@ cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = d -- Full canonical names of imported modules importDeclerations = map unLoc limports + -- The list of all importable Modules from all packages + moduleNames = map showModName (envVisibleModuleNames env) + -- The given namespaces for the imported modules (ie. full name, or alias if used) allModNamesAsNS = map (showModName . asNamespace) importDeclerations @@ -364,24 +365,14 @@ cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = d return $ mkNameCompItem uri mbParent originName mn ty Nothing docs imp' : recordCompls - -- The list of all importable Modules from all packages - (lvmnDiags, moduleNames) <- - catchSrcErrors - dflags - "listVisibleModuleNames" - (evaluate . force $ map showModName (listVisibleModuleNames dflags)) - <&> \case - Left diags -> (diags, []) - Right x -> ([], x) - (unquals,quals) <- getCompls rdrElts - return (lvmnDiags, CC + return $ CC { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals , qualCompls = quals , importableModules = moduleNames - }) + } -- | Produces completions from the top level declarations of a module. localCompletionsForParsedModule :: Uri -> ParsedModule -> CachedCompletions diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index fdf29426a5..8016d2888e 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -6,6 +6,7 @@ module Development.IDE.Types.HscEnvEq newHscEnvEqWithImportPaths, envImportPaths, envPackageExports, + envVisibleModuleNames, deps ) where @@ -16,7 +17,7 @@ import Development.Shake.Classes import Module (InstalledUnitId) import System.Directory (canonicalizePath) import Development.IDE.GHC.Compat -import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId) +import GhcPlugins(HscEnv (hsc_dflags), PackageState (explicitPackages), InstalledPackageInfo (exposedModules), Module(..), packageConfigId, listVisibleModuleNames) import System.FilePath import Development.IDE.GHC.Util (lookupPackageConfig) import Control.Monad.IO.Class @@ -27,7 +28,10 @@ import OpenTelemetry.Eventlog (withSpan) import Control.Monad.Extra (mapMaybeM, join, eitherM) import Control.Concurrent.Extra (newVar, modifyVar) import Control.Concurrent.Async (Async, async, waitCatch) -import Control.Exception (throwIO, mask) +import Control.Exception (throwIO, mask, evaluate) +import Development.IDE.GHC.Error (catchSrcErrors) +import Control.DeepSeq (force) +import Data.Either (fromRight) -- | An 'HscEnv' with equality. Two values are considered equal -- if they are created with the same call to 'newHscEnvEq'. @@ -42,6 +46,7 @@ data HscEnvEq = HscEnvEq -- ^ If Just, import dirs originally configured in this env -- If Nothing, the env import dirs are unaltered , envPackageExports :: IO ExportsMap + , envVisibleModuleNames :: [ModuleName] } -- | Wrap an 'HscEnv' into an 'HscEnvEq'. @@ -58,12 +63,15 @@ newHscEnvEq cradlePath hscEnv0 deps = do newHscEnvEqWithImportPaths :: Maybe [String] -> HscEnv -> [(InstalledUnitId, DynFlags)] -> IO HscEnvEq newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do + + let dflags = hsc_dflags hscEnv + envUnique <- newUnique -- it's very important to delay the package exports computation envPackageExports <- onceAsync $ withSpan "Package Exports" $ \_sp -> do -- compute the package imports - let pkgst = pkgState (hsc_dflags hscEnv) + let pkgst = pkgState dflags depends = explicitPackages pkgst targets = [ (pkg, mn) @@ -82,6 +90,14 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do Maybes.Succeeded mi -> Just mi modIfaces <- mapMaybeM doOne targets return $ createExportsMap modIfaces + + envVisibleModuleNames <- + fromRight [] + <$> catchSrcErrors + dflags + "listVisibleModuleNames" + (evaluate . force $ listVisibleModuleNames dflags) + return HscEnvEq{..} -- | Wrap an 'HscEnv' into an 'HscEnvEq'. @@ -108,9 +124,9 @@ instance Eq HscEnvEq where a == b = envUnique a == envUnique b instance NFData HscEnvEq where - rnf (HscEnvEq a b c d _) = + rnf (HscEnvEq a b c d _ f) = -- deliberately skip the package exports map - rnf (hashUnique a) `seq` b `seq` c `seq` rnf d + rnf (hashUnique a) `seq` b `seq` c `seq` d `seq` rnf f instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique From 68511e284d0adba4711cdcbe231326b9ef8bb659 Mon Sep 17 00:00:00 2001 From: Potato Hatsue <1793913507@qq.com> Date: Sun, 14 Feb 2021 21:02:32 +0800 Subject: [PATCH 3/3] Make envVisibleModuleNames lazy --- .../IDE/Plugin/Completions/Logic.hs | 5 +++-- ghcide/src/Development/IDE/Types/HscEnvEq.hs | 19 ++++++++++++------- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs index d513a090e8..f17de8ed63 100644 --- a/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs +++ b/ghcide/src/Development/IDE/Plugin/Completions/Logic.hs @@ -310,8 +310,6 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports deps = do -- Full canonical names of imported modules importDeclerations = map unLoc limports - -- The list of all importable Modules from all packages - moduleNames = map showModName (envVisibleModuleNames env) -- The given namespaces for the imported modules (ie. full name, or alias if used) allModNamesAsNS = map (showModName . asNamespace) importDeclerations @@ -367,6 +365,9 @@ cacheDataProducer uri env curMod globalEnv inScopeEnv limports deps = do (unquals,quals) <- getCompls rdrElts + -- The list of all importable Modules from all packages + moduleNames <- maybe [] (map showModName) <$> envVisibleModuleNames env + return $ CC { allModNamesAsNS = allModNamesAsNS , unqualCompls = unquals diff --git a/ghcide/src/Development/IDE/Types/HscEnvEq.hs b/ghcide/src/Development/IDE/Types/HscEnvEq.hs index 8016d2888e..9a907149ff 100644 --- a/ghcide/src/Development/IDE/Types/HscEnvEq.hs +++ b/ghcide/src/Development/IDE/Types/HscEnvEq.hs @@ -46,7 +46,11 @@ data HscEnvEq = HscEnvEq -- ^ If Just, import dirs originally configured in this env -- If Nothing, the env import dirs are unaltered , envPackageExports :: IO ExportsMap - , envVisibleModuleNames :: [ModuleName] + , envVisibleModuleNames :: IO (Maybe [ModuleName]) + -- ^ 'listVisibleModuleNames' is a pure function, + -- but it could panic due to a ghc bug: https://github.com/haskell/haskell-language-server/issues/1365 + -- So it's wrapped in IO here for error handling + -- If Nothing, 'listVisibleModuleNames' panic } -- | Wrap an 'HscEnv' into an 'HscEnvEq'. @@ -91,12 +95,13 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do modIfaces <- mapMaybeM doOne targets return $ createExportsMap modIfaces - envVisibleModuleNames <- - fromRight [] + -- similar to envPackageExports, evaluated lazily + envVisibleModuleNames <- onceAsync $ + fromRight Nothing <$> catchSrcErrors dflags "listVisibleModuleNames" - (evaluate . force $ listVisibleModuleNames dflags) + (evaluate . force . Just $ listVisibleModuleNames dflags) return HscEnvEq{..} @@ -124,9 +129,9 @@ instance Eq HscEnvEq where a == b = envUnique a == envUnique b instance NFData HscEnvEq where - rnf (HscEnvEq a b c d _ f) = - -- deliberately skip the package exports map - rnf (hashUnique a) `seq` b `seq` c `seq` d `seq` rnf f + rnf (HscEnvEq a b c d _ _) = + -- deliberately skip the package exports map and visible module names + rnf (hashUnique a) `seq` b `seq` c `seq` rnf d instance Hashable HscEnvEq where hashWithSalt s = hashWithSalt s . envUnique