Add "Goto Implementation" LSP handler

Adds the necessary instances for handling the request type `Method_TextDocumentImplementation`. Further, wire up the appropriate handlers for the "gotoImplementation" request.
haskell · Aug 29, 2024 · d222aee · d222aee
1 parent 763d70d
commit d222aee
Show file tree

Hide file tree

Showing 6 changed files with 73 additions and 25 deletions.
diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs
@@ -3,6 +3,7 @@ module Development.IDE.Core.Actions
 ( getAtPoint
 , getDefinition
 , getTypeDefinition
+, getImplementationDefinition
 , highlightAtPoint
 , refsAtPoint
 , workspaceSymbols
@@ -120,6 +121,16 @@ getTypeDefinition file pos = runMaybeT $ do
       pure $ Just (fixedLocation, identifier)
       ) locationsWithIdentifier
 
+getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
+getImplementationDefinition file pos = runMaybeT $ do
+    ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
+    opts <- liftIO $ getIdeOptionsIO ide
+    (hf, mapping) <- useWithStaleFastMT GetHieAst file
+    (ImportMap imports, _) <- useWithStaleFastMT GetImportMap file
+    !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
+    locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts imports hf pos'
+    traverse (MaybeT . toCurrentLocation mapping file) locs
+
 highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
 highlightAtPoint file pos = runMaybeT $ do
     (HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file

diff --git a/ghcide/src/Development/IDE/LSP/HoverDefinition.hs b/ghcide/src/Development/IDE/LSP/HoverDefinition.hs
@@ -9,6 +9,7 @@ module Development.IDE.LSP.HoverDefinition
     , hover
     , gotoDefinition
     , gotoTypeDefinition
+    , gotoImplementation
     , documentHighlight
     , references
     , wsSymbols
@@ -46,9 +47,11 @@ instance Pretty Log where
 gotoDefinition     :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition)
 hover              :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null)
 gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition)
+gotoImplementation :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentImplementation)
 documentHighlight  :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)
-gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR . map fst)
-gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR . map fst)
+gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition . InR . map fst)
+gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition . InR . map fst)
+gotoImplementation = request "InstanceDefinition" getImplementationDefinition (InR $ InR Null) (InL . Definition . InR)
 hover          = request "Hover"      getAtPoint     (InR Null)     foundHover
 documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL
 

diff --git a/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs b/ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs
@@ -51,6 +51,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc)
                       Hover.gotoDefinition recorder ide TextDocumentPositionParams{..})
                   <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->
                       Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..})
+                  <> mkPluginHandler SMethod_TextDocumentImplementation (\ide _ ImplementationParams{..} ->
+                      Hover.gotoImplementation recorder ide TextDocumentPositionParams{..})
                   <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->
                       Hover.documentHighlight recorder ide TextDocumentPositionParams{..})
                   <> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder)

diff --git a/ghcide/src/Development/IDE/Spans/AtPoint.hs b/ghcide/src/Development/IDE/Spans/AtPoint.hs
@@ -10,6 +10,7 @@ module Development.IDE.Spans.AtPoint (
     atPoint
   , gotoDefinition
   , gotoTypeDefinition
+  , gotoImplementation
   , documentHighlight
   , pointCommand
   , referencesAtPoint
@@ -214,6 +215,20 @@ gotoDefinition
 gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos
   = lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans
 
+-- | Locate the implementation definition of the name at a given position.
+-- Finds the implementation for a overloaded function.
+gotoImplementation
+  :: MonadIO m
+  => WithHieDb
+  -> LookupModule m
+  -> IdeOptions
+  -> M.Map ModuleName NormalizedFilePath
+  -> HieAstResult
+  -> Position
+  -> MaybeT m [Location]
+gotoImplementation withHieDb getHieFile ideOpts imports srcSpans pos
+  = lift $ instanceLocationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans
+
 -- | Synopsis for the name at a given position.
 atPoint
   :: IdeOptions
@@ -228,7 +243,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
     -- Hover info for values/data
     hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text])
     hoverInfo ast = do
-        prettyNames <- mapM prettyName filteredNames
+        prettyNames <- mapM prettyName names
         pure (Just range, prettyNames ++ pTypes)
       where
         pTypes :: [T.Text]
@@ -245,27 +260,20 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
         info :: NodeInfo hietype
         info = nodeInfoH kind ast
 
+        -- We want evidence variables to be displayed last.
+        -- Evidence trees contain information of secondary relevance.
         names :: [(Identifier, IdentifierDetails hietype)]
         names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info
 
-        -- Check for evidence bindings
-        isInternal :: (Identifier, IdentifierDetails a) -> Bool
-        isInternal (Right _, dets) =
-          any isEvidenceContext $ identInfo dets
-        isInternal (Left _, _) = False
-
-        filteredNames :: [(Identifier, IdentifierDetails hietype)]
-        filteredNames = filter (not . isInternal) names
-
         prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text
         prettyName (Right n, dets)
-          | any isEvidenceUse (identInfo dets) =
-            pure $ maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) <> "\n"
+          -- We don't want to print evidence variables as they are generated.
+          | any isEvidenceUse (identInfo dets) = pure $ maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) <> "\n"
           | otherwise = pure $ T.unlines $
             wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))
             : maybeToList (pretty (definedAt n) (prettyPackageName n))
             ++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n
-                        ]
+                         ]
           where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n
                 pretty Nothing Nothing = Nothing
                 pretty (Just define) Nothing = Just $ define <> "\n"
@@ -299,7 +307,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
               version = T.pack $ showVersion (unitPackageVersion conf)
           pure $ pkgName <> "-" <> version
 
-        -- Type info for the current node, it may contains several symbols
+        -- Type info for the current node, it may contain several symbols
         -- for one range, like wildcard
         types :: [hietype]
         types = nodeType info
@@ -308,10 +316,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
         prettyTypes = map (("_ :: "<>) . prettyType) types
 
         prettyType :: hietype -> T.Text
-        prettyType t = case kind of
-          HieFresh -> printOutputable t
-          HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file)
-        -- prettyType = printOutputable . expandType
+        prettyType = printOutputable . expandType
 
         expandType :: a -> SDoc
         expandType t = case kind of
@@ -418,16 +423,37 @@ locationsAtPoint
   -> HieAstResult
   -> m [(Location, Identifier)]
 locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =
+  let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)
+      zeroPos = Position 0 0
+      zeroRange = Range zeroPos zeroPos
+      modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports
+   in fmap (nubOrd . concat) $ mapMaybeM
+        (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m)))
+                (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n)))
+        ns
+
+-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's.
+instanceLocationsAtPoint
+  :: forall m
+   . MonadIO m
+  => WithHieDb
+  -> LookupModule m
+  -> IdeOptions
+  -> M.Map ModuleName NormalizedFilePath
+  -> Position
+  -> HieAstResult
+  -> m [Location]
+instanceLocationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =
   let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)
       evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns
       evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees
       zeroPos = Position 0 0
       zeroRange = Range zeroPos zeroPos
       modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports
-   in fmap (nubOrd . concat) $ mapMaybeM
+   in fmap (fmap fst . nubOrd . concat) $ mapMaybeM
         (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m)))
                 (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n)))
-        (ns ++ evNs)
+        evNs
 
 -- | Given a 'Name' attempt to find the location where it is defined.
 nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])

diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs
@@ -33,9 +33,7 @@ tests = withResource acquire release tests where
     , chk "NO signature help"        _signatureHelpProvider Nothing
     , chk "   goto definition"          _definitionProvider (Just $ InR (DefinitionOptions (Just False)))
     , chk "   goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False))))
-    -- BUG in lsp-test, this test fails, just change the accepted response
-    -- for now
-    , chk "NO goto implementation"  _implementationProvider Nothing
+    , chk "   goto implementation"  _implementationProvider (Just $ InR (InL (ImplementationOptions (Just False))))
     , chk "   find references"          _referencesProvider (Just $ InR (ReferenceOptions (Just False)))
     , chk "   doc highlight"     _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False)))
     , chk "   doc symbol"           _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing))

diff --git a/hls-plugin-api/src/Ide/Types.hs b/hls-plugin-api/src/Ide/Types.hs
@@ -504,6 +504,9 @@ instance PluginMethod Request Method_TextDocumentDefinition where
 instance PluginMethod Request Method_TextDocumentTypeDefinition where
   handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
 
+instance PluginMethod Request Method_TextDocumentImplementation where
+  handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
+
 instance PluginMethod Request Method_TextDocumentDocumentHighlight where
   handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
 
@@ -697,6 +700,11 @@ instance PluginRequestMethod Method_TextDocumentTypeDefinition where
         | Just (Just True) <- caps ^? (L.textDocument . _Just . L.typeDefinition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs
         | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs
 
+instance PluginRequestMethod Method_TextDocumentImplementation where
+    combineResponses _ _ caps _ (x :| xs)
+        | Just (Just True) <- caps ^? (L.textDocument . _Just . L.typeDefinition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs
+        | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs
+
 instance PluginRequestMethod Method_TextDocumentDocumentHighlight where
 
 instance PluginRequestMethod Method_TextDocumentReferences where