Catch GHC errors in listing module names (#1367)

* Catch GHC errors in listing module names

* Move visible module names to HscEnvEq

* Make envVisibleModuleNames lazy

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

Author: berberman

ghcide/src/Development/IDE/Plugin/Completions.hs

@@ -83,7 +83,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
+                      cdata <- liftIO $ cacheDataProducer uri sess (ms_mod ms) globalEnv inScopeEnv imps parsedDeps
                       return ([], Just cdata)
                   (_diag, _) ->
                       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,6 +58,7 @@ import Data.Functor
 import Ide.PluginUtils (mkLspCommand)
 import Ide.Types (CommandId (..), PluginId, WithSnippets (..))
 import Control.Monad
+import Development.IDE.Types.HscEnvEq
 
 -- From haskell-ide-engine/hie-plugin-api/Haskell/Ide/Engine/Context.hs
 
@@ -294,9 +294,10 @@ mkPragmaCompl label insertText =
     Nothing Nothing Nothing Nothing Nothing
 
 
-cacheDataProducer :: Uri -> HscEnv -> Module -> GlobalRdrEnv-> GlobalRdrEnv -> [LImportDecl GhcPs] -> [ParsedModule] -> IO 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 ]
@@ -309,8 +310,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
@@ -366,6 +365,9 @@ cacheDataProducer uri packageState curMod globalEnv inScopeEnv limports deps = d
 
   (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

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,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 :: 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'.
@@ -58,12 +67,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 +94,15 @@ newHscEnvEqWithImportPaths envImportPaths hscEnv deps = do
                     Maybes.Succeeded mi -> Just mi
         modIfaces <- mapMaybeM doOne targets
         return $ createExportsMap modIfaces
+
+    -- similar to envPackageExports, evaluated lazily
+    envVisibleModuleNames <- onceAsync $
+      fromRight Nothing
+        <$> catchSrcErrors
+          dflags
+          "listVisibleModuleNames"
+          (evaluate . force . Just $ listVisibleModuleNames dflags)
+
     return HscEnvEq{..}
 
 -- | Wrap an 'HscEnv' into an 'HscEnvEq'.
@@ -108,8 +129,8 @@ instance Eq HscEnvEq where
   a == b = envUnique a == envUnique b
 
 instance NFData HscEnvEq where
-  rnf (HscEnvEq a b c d _) =
-      -- deliberately skip the package exports map
+  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