Catch GHC errors in listing module names

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)

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

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