Implement completionItem/resolve

Author: wz1000

ghcide/src/Development/IDE/Core/Compile.hs

@@ -1592,15 +1592,14 @@ coreFileToLinkable linkableType session ms iface details core_file t = do
 --- and leads to fun errors like "Cannot continue after interface file error".
 getDocsBatch
   :: HscEnv
-  -> Module  -- ^ a module where the names are in scope
   -> [Name]
 #if MIN_VERSION_ghc(9,3,0)
   -> IO [Either String (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn))]
 #else
   -> IO [Either String (Maybe HsDocString, IntMap HsDocString)]
 #endif
-getDocsBatch hsc_env _mod _names = do
-    (msgs, res) <- initTc hsc_env HsSrcFile False _mod fakeSpan $ forM _names $ \name ->
+getDocsBatch hsc_env _names = do
+    res <- initIfaceLoad hsc_env $ forM _names $ \name ->
         case nameModule_maybe name of
             Nothing -> return (Left $ NameHasNoModule name)
             Just mod -> do
@@ -1615,7 +1614,7 @@ getDocsBatch hsc_env _mod _names = do
                       , mi_decl_docs = DeclDocMap dmap
                       , mi_arg_docs = ArgDocMap amap
 #endif
-                      } <- loadModuleInterface "getModuleInterface" mod
+                      } <- loadSysInterface (text "getModuleInterface") mod
 #if MIN_VERSION_ghc(9,3,0)
              if isNothing mb_doc_hdr && isNullUniqMap dmap && isNullUniqMap amap
 #else
@@ -1636,44 +1635,42 @@ getDocsBatch hsc_env _mod _names = do
 #else
                                   Map.findWithDefault mempty name amap))
 #endif
-    case res of
-        Just x  -> return $ map (first $ T.unpack . printOutputable)
-                          $ x
-        Nothing -> throwErrors
-#if MIN_VERSION_ghc(9,3,0)
-                     $ fmap GhcTcRnMessage msgs
-#elif MIN_VERSION_ghc(9,2,0)
-                     $ Error.getErrorMessages msgs
-#else
-                     $ snd msgs
-#endif
+    return $ map (first $ T.unpack . printOutputable)
+           $ res
   where
-    throwErrors = liftIO . throwIO . mkSrcErr
     compiled n =
       -- TODO: Find a more direct indicator.
       case nameSrcLoc n of
         RealSrcLoc {}   -> False
         UnhelpfulLoc {} -> True
 
-fakeSpan :: RealSrcSpan
-fakeSpan = realSrcLocSpan $ mkRealSrcLoc (Util.fsLit "<ghcide>") 1 1
-
 -- | Non-interactive, batch version of 'InteractiveEval.lookupNames'.
 --   The interactive paths create problems in ghc-lib builds
 --- and leads to fun errors like "Cannot continue after interface file error".
 lookupName :: HscEnv
-           -> Module -- ^ A module where the Names are in scope
            -> Name
            -> IO (Maybe TyThing)
-lookupName hsc_env mod name = do
-    (_messages, res) <- initTc hsc_env HsSrcFile False mod fakeSpan $ do
-        tcthing <- tcLookup name
-        case tcthing of
-            AGlobal thing    -> return thing
-            ATcId{tct_id=id} -> return (AnId id)
-            _                -> panic "tcRnLookupName'"
-    return res
-
+lookupName _ name
+  | Nothing <- nameModule_maybe name = pure Nothing
+lookupName hsc_env name = do
+#if MIN_VERSION_ghc(9,2,0)
+  mb_thing <- liftIO $ lookupType hsc_env name
+#else
+  eps <- liftIO $ readIORef (hsc_EPS hsc_env)
+  let mb_thing = lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name
+#endif
+  case mb_thing of
+    x@(Just _) -> return x
+    Nothing
+      | x@(Just thing) <- wiredInNameTyThing_maybe name
+      -> do when (needWiredInHomeIface thing)
+                 (initIfaceLoad hsc_env (loadWiredInHomeIface name))
+            return x
+      | otherwise -> do
+        res <- initIfaceLoad hsc_env $ importDecl name
+        case res of
+          Util.Succeeded x -> return (Just x)
+          _ -> return Nothing
 
 pathToModuleName :: FilePath -> ModuleName
 pathToModuleName = mkModuleName . map rep

ghcide/src/Development/IDE/GHC/Compat.hs

@@ -22,6 +22,7 @@ module Development.IDE.GHC.Compat(
 #else
     upNameCache,
 #endif
+    lookupNameCache,
     disableWarningsAsErrors,
     reLoc,
     reLocA,
@@ -416,6 +417,25 @@ hieExportNames = nameListFromAvails . hie_exports
 #if MIN_VERSION_ghc(9,3,0)
 type NameCacheUpdater = NameCache
 #else
+
+lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
+-- Lookup up the (Module,OccName) in the NameCache
+-- If you find it, return it; if not, allocate a fresh original name and extend
+-- the NameCache.
+-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
+-- If we need to explore its value we will load Foo.hi; but meanwhile all we
+-- need is a Name for it.
+lookupNameCache mod occ name_cache =
+  case lookupOrigNameCache (nsNames name_cache) mod occ of {
+    Just name -> (name_cache, name);
+    Nothing   ->
+        case takeUniqFromSupply (nsUniqs name_cache) of {
+          (uniq, us) ->
+              let
+                name      = mkExternalName uniq mod occ noSrcSpan
+                new_cache = extendNameCache (nsNames name_cache) mod occ name
+              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}
+
 upNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
 upNameCache = updNameCache
 #endif

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -36,7 +36,14 @@ module Development.IDE.GHC.Compat.Core (
     maxRefHoleFits,
     maxValidHoleFits,
     setOutputFile,
+    lookupType,
+    needWiredInHomeIface,
+    loadWiredInHomeIface,
+    loadSysInterface,
+    importDecl,
+#if MIN_VERSION_ghc(8,8,0)
     CommandLineOption,
+#endif
 #if !MIN_VERSION_ghc(9,2,0)
     staticPlugins,
 #endif

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

@@ -12,21 +12,27 @@ module Development.IDE.Plugin.Completions
 import           Control.Concurrent.Async                 (concurrently)
 import           Control.Concurrent.STM.Stats             (readTVarIO)
 import           Control.Monad.IO.Class
+import           Control.Lens                            ((&), (.~))
 import qualified Data.HashMap.Strict                      as Map
 import qualified Data.HashSet                             as Set
+import           Data.Aeson
 import           Data.Maybe
 import qualified Data.Text                                as T
 import           Development.IDE.Core.PositionMapping
+import           Development.IDE.Core.Compile
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service             hiding (Log, LogShake)
 import           Development.IDE.Core.Shake               hiding (Log)
 import qualified Development.IDE.Core.Shake               as Shake
 import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.Util
 import           Development.IDE.Graph
+import           Development.IDE.Spans.Common
+import           Development.IDE.Spans.Documentation
 import           Development.IDE.Plugin.Completions.Logic
 import           Development.IDE.Plugin.Completions.Types
 import           Development.IDE.Types.Exports
-import           Development.IDE.Types.HscEnvEq           (HscEnvEq (envPackageExports),
+import           Development.IDE.Types.HscEnvEq           (HscEnvEq (envPackageExports, envVisibleModuleNames),
                                                            hscEnv)
 import qualified Development.IDE.Types.KnownTargets       as KT
 import           Development.IDE.Types.Location
@@ -37,6 +43,8 @@ import           Development.IDE.Types.Logger             (Pretty (pretty),
 import           Ide.Types
 import qualified Language.LSP.Server                      as LSP
 import           Language.LSP.Types
+import qualified Language.LSP.Types.Lens         as J
+import qualified Language.LSP.VFS                         as VFS
 import           Numeric.Natural
 import           Text.Fuzzy.Parallel                      (Scored (..))
 
@@ -57,10 +65,12 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta
 descriptor recorder plId = (defaultPluginDescriptor plId)
   { pluginRules = produceCompletions recorder
   , pluginHandlers = mkPluginHandler STextDocumentCompletion getCompletionsLSP
+                  <> mkPluginHandler SCompletionItemResolve resolveCompletion
   , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
   , pluginPriority = ghcideCompletionsPluginPriority
   }
 
+
 produceCompletions :: Recorder (WithPriority Log) -> Rules ()
 produceCompletions recorder = do
     define (cmapWithPrio LogShake recorder) $ \LocalCompletions file -> do
@@ -85,8 +95,9 @@ produceCompletions recorder = do
               (global, inScope) <- liftIO $ tcRnImportDecls env (dropListFromImportDecl <$> msrImports) `concurrently` tcRnImportDecls env msrImports
               case (global, inScope) of
                   ((_, Just globalEnv), (_, Just inScopeEnv)) -> do
+                      visibleMods <- liftIO $ fmap (fromMaybe []) $ envVisibleModuleNames sess
                       let uri = fromNormalizedUri $ normalizedFilePathToUri file
-                      cdata <- liftIO $ cacheDataProducer uri sess (ms_mod msrModSummary) globalEnv inScopeEnv msrImports
+                      let cdata = cacheDataProducer uri visibleMods (ms_mod msrModSummary) globalEnv inScopeEnv msrImports
                       return ([], Just cdata)
                   (_diag, _) ->
                       return ([], Nothing)
@@ -102,6 +113,49 @@ dropListFromImportDecl iDecl = let
     f x = x
     in f <$> iDecl
 
+resolveCompletion :: IdeState -> PluginId -> CompletionItem -> LSP.LspM Config (Either ResponseError CompletionItem)
+resolveCompletion ide _ comp@CompletionItem{_detail,_documentation,_xdata}
+  | Just resolveData <- _xdata
+  , Success (CompletionResolveData uri needType (NameDetails mod occ)) <- fromJSON resolveData
+  , Just file <- uriToNormalizedFilePath $ toNormalizedUri uri
+  = liftIO $ runIdeAction "Completion resolve" (shakeExtras ide) $ do
+    msess <- useWithStaleFast GhcSessionDeps file
+    case msess of
+      Nothing -> pure (Right comp) -- File doesn't compile, return original completion item
+      Just (sess,_) -> do
+        let nc = ideNc $ shakeExtras ide
+#if MIN_VERSION_ghc(9,3,0)
+        name <- liftIO $ lookupNameCache nc mod occ
+#else
+        name <- liftIO $ upNameCache nc (lookupNameCache mod occ)
+#endif
+        mdkm <- useWithStaleFast GetDocMap file
+        let (dm,km) = case mdkm of
+              Just (DKMap dm km, _) -> (dm,km)
+              Nothing -> (mempty, mempty)
+        doc <- case lookupNameEnv dm name of
+          Just doc -> pure $ spanDocToMarkdown doc
+          Nothing -> liftIO $ spanDocToMarkdown <$> getDocumentationTryGhc (hscEnv sess) name
+        typ <- case lookupNameEnv km name of
+          _ | not needType -> pure Nothing
+          Just ty -> pure (safeTyThingType ty)
+          Nothing -> do
+            (safeTyThingType =<<) <$> liftIO (lookupName (hscEnv sess) name)
+        let det1 = case typ of
+              Just ty -> Just (":: " <> printOutputable (stripForall ty) <> "\n")
+              Nothing -> Nothing
+            doc1 = case _documentation of
+              Just (CompletionDocMarkup (MarkupContent MkMarkdown old)) ->
+                CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator (old:doc)
+              _ -> CompletionDocMarkup $ MarkupContent MkMarkdown $ T.intercalate sectionSeparator doc
+        pure (Right $ comp & J.detail .~ (det1 <> _detail)
+                           & J.documentation .~ Just doc1
+                           )
+  where
+    stripForall ty = case splitForAllTyCoVars ty of
+      (_,res) -> res
+resolveCompletion _ _ comp = pure (Right comp)
+
 -- | Generate code actions.
 getCompletionsLSP
     :: IdeState
@@ -160,7 +214,7 @@ getCompletionsLSP ide plId
                     plugins = idePlugins $ shakeExtras ide
                 config <- liftIO $ runAction "" ide $ getCompletionsConfig plId
 
-                allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports
+                allCompletions <- liftIO $ getCompletions plugins ideOpts cci' parsedMod astres bindMap pfix clientCaps config moduleExports uri
                 pure $ InL (List $ orderedCompletions allCompletions)
               _ -> return (InL $ List [])
           _ -> return (InL $ List [])