Skip to content

Commit 0ccc4d3

Browse files
fendorfendor
committed
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.
1 parent 763d70d commit 0ccc4d3

File tree

7 files changed

+93
-26
lines changed

7 files changed

+93
-26
lines changed

‎ghcide/src/Development/IDE/Core/Actions.hs

+11
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,7 @@ module Development.IDE.Core.Actions
33
( getAtPoint
44
, getDefinition
55
, getTypeDefinition
6+
, getImplementationDefinition
67
, highlightAtPoint
78
, refsAtPoint
89
, workspaceSymbols
@@ -120,6 +121,16 @@ getTypeDefinition file pos = runMaybeT $ do
120121
pure $ Just (fixedLocation, identifier)
121122
) locationsWithIdentifier
122123

124+
getImplementationDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
125+
getImplementationDefinition file pos = runMaybeT $ do
126+
ide@ShakeExtras{ withHieDb, hiedbWriter } <- ask
127+
opts <- liftIO $ getIdeOptionsIO ide
128+
(hf, mapping) <- useWithStaleFastMT GetHieAst file
129+
(ImportMap imports, _) <- useWithStaleFastMT GetImportMap file
130+
!pos' <- MaybeT (pure $ fromCurrentPosition mapping pos)
131+
locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts imports hf pos'
132+
traverse (MaybeT . toCurrentLocation mapping file) locs
133+
123134
highlightAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe [DocumentHighlight])
124135
highlightAtPoint file pos = runMaybeT $ do
125136
(HAR _ hf rf _ _,mapping) <- useWithStaleFastMT GetHieAst file

‎ghcide/src/Development/IDE/LSP/HoverDefinition.hs

+5-2
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Development.IDE.LSP.HoverDefinition
99
, hover
1010
, gotoDefinition
1111
, gotoTypeDefinition
12+
, gotoImplementation
1213
, documentHighlight
1314
, references
1415
, wsSymbols
@@ -46,9 +47,11 @@ instance Pretty Log where
4647
gotoDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentDefinition)
4748
hover :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (Hover |? Null)
4849
gotoTypeDefinition :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentTypeDefinition)
50+
gotoImplementation :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) (MessageResult Method_TextDocumentImplementation)
4951
documentHighlight :: Recorder (WithPriority Log) -> IdeState -> TextDocumentPositionParams -> ExceptT PluginError (HandlerM c) ([DocumentHighlight] |? Null)
50-
gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR . map fst)
51-
gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR . map fst)
52+
gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition . InR . map fst)
53+
gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition . InR . map fst)
54+
gotoImplementation = request "InstanceDefinition" getImplementationDefinition (InR $ InR Null) (InL . Definition . InR)
5255
hover = request "Hover" getAtPoint (InR Null) foundHover
5356
documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL
5457

‎ghcide/src/Development/IDE/Plugin/HLS/GhcIde.hs

+2
Original file line numberDiff line numberDiff line change
@@ -51,6 +51,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc)
5151
Hover.gotoDefinition recorder ide TextDocumentPositionParams{..})
5252
<> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} ->
5353
Hover.gotoTypeDefinition recorder ide TextDocumentPositionParams{..})
54+
<> mkPluginHandler SMethod_TextDocumentImplementation (\ide _ ImplementationParams{..} ->
55+
Hover.gotoImplementation recorder ide TextDocumentPositionParams{..})
5456
<> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} ->
5557
Hover.documentHighlight recorder ide TextDocumentPositionParams{..})
5658
<> mkPluginHandler SMethod_TextDocumentReferences (Hover.references recorder)

‎ghcide/src/Development/IDE/Spans/AtPoint.hs

+46-20
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module Development.IDE.Spans.AtPoint (
1010
atPoint
1111
, gotoDefinition
1212
, gotoTypeDefinition
13+
, gotoImplementation
1314
, documentHighlight
1415
, pointCommand
1516
, referencesAtPoint
@@ -214,6 +215,20 @@ gotoDefinition
214215
gotoDefinition withHieDb getHieFile ideOpts imports srcSpans pos
215216
= lift $ locationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans
216217

218+
-- | Locate the implementation definition of the name at a given position.
219+
-- Finds the implementation for a overloaded function.
220+
gotoImplementation
221+
:: MonadIO m
222+
=> WithHieDb
223+
-> LookupModule m
224+
-> IdeOptions
225+
-> M.Map ModuleName NormalizedFilePath
226+
-> HieAstResult
227+
-> Position
228+
-> MaybeT m [Location]
229+
gotoImplementation withHieDb getHieFile ideOpts imports srcSpans pos
230+
= lift $ instanceLocationsAtPoint withHieDb getHieFile ideOpts imports pos srcSpans
231+
217232
-- | Synopsis for the name at a given position.
218233
atPoint
219234
:: IdeOptions
@@ -228,7 +243,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
228243
-- Hover info for values/data
229244
hoverInfo :: HieAST hietype -> IO (Maybe Range, [T.Text])
230245
hoverInfo ast = do
231-
prettyNames <- mapM prettyName filteredNames
246+
prettyNames <- mapM prettyName names
232247
pure (Just range, prettyNames ++ pTypes)
233248
where
234249
pTypes :: [T.Text]
@@ -245,27 +260,20 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
245260
info :: NodeInfo hietype
246261
info = nodeInfoH kind ast
247262

263+
-- We want evidence variables to be displayed last.
264+
-- Evidence trees contain information of secondary relevance.
248265
names :: [(Identifier, IdentifierDetails hietype)]
249266
names = sortOn (any isEvidenceUse . identInfo . snd) $ M.assocs $ nodeIdentifiers info
250267

251-
-- Check for evidence bindings
252-
isInternal :: (Identifier, IdentifierDetails a) -> Bool
253-
isInternal (Right _, dets) =
254-
any isEvidenceContext $ identInfo dets
255-
isInternal (Left _, _) = False
256-
257-
filteredNames :: [(Identifier, IdentifierDetails hietype)]
258-
filteredNames = filter (not . isInternal) names
259-
260268
prettyName :: (Either ModuleName Name, IdentifierDetails hietype) -> IO T.Text
261269
prettyName (Right n, dets)
262-
| any isEvidenceUse (identInfo dets) =
263-
pure $ maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) <> "\n"
270+
-- We don't want to print evidence variables as they are generated.
271+
| any isEvidenceUse (identInfo dets) = pure $ maybe "" (printOutputable . renderEvidenceTree) (getEvidenceTree rf n) <> "\n"
264272
| otherwise = pure $ T.unlines $
265273
wrapHaskell (printOutputable n <> maybe "" (" :: " <>) ((prettyType <$> identType dets) <|> maybeKind))
266274
: maybeToList (pretty (definedAt n) (prettyPackageName n))
267275
++ catMaybes [ T.unlines . spanDocToMarkdown <$> lookupNameEnv dm n
268-
]
276+
]
269277
where maybeKind = fmap printOutputable $ safeTyThingType =<< lookupNameEnv km n
270278
pretty Nothing Nothing = Nothing
271279
pretty (Just define) Nothing = Just $ define <> "\n"
@@ -299,7 +307,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
299307
version = T.pack $ showVersion (unitPackageVersion conf)
300308
pure $ pkgName <> "-" <> version
301309

302-
-- Type info for the current node, it may contains several symbols
310+
-- Type info for the current node, it may contain several symbols
303311
-- for one range, like wildcard
304312
types :: [hietype]
305313
types = nodeType info
@@ -308,10 +316,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D
308316
prettyTypes = map (("_ :: "<>) . prettyType) types
309317

310318
prettyType :: hietype -> T.Text
311-
prettyType t = case kind of
312-
HieFresh -> printOutputable t
313-
HieFromDisk full_file -> printOutputable $ hieTypeToIface $ recoverFullType t (hie_types full_file)
314-
-- prettyType = printOutputable . expandType
319+
prettyType = printOutputable . expandType
315320

316321
expandType :: a -> SDoc
317322
expandType t = case kind of
@@ -418,16 +423,37 @@ locationsAtPoint
418423
-> HieAstResult
419424
-> m [(Location, Identifier)]
420425
locationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =
426+
let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)
427+
zeroPos = Position 0 0
428+
zeroRange = Range zeroPos zeroPos
429+
modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports
430+
in fmap (nubOrd . concat) $ mapMaybeM
431+
(either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m)))
432+
(\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n)))
433+
ns
434+
435+
-- | Find 'Location's of definition at a specific point and return them along with their 'Identifier's.
436+
instanceLocationsAtPoint
437+
:: forall m
438+
. MonadIO m
439+
=> WithHieDb
440+
-> LookupModule m
441+
-> IdeOptions
442+
-> M.Map ModuleName NormalizedFilePath
443+
-> Position
444+
-> HieAstResult
445+
-> m [Location]
446+
instanceLocationsAtPoint withHieDb lookupModule _ideOptions imports pos (HAR _ ast _rm _ _) =
421447
let ns = concat $ pointCommand ast pos (M.keys . getNodeIds)
422448
evTrees = mapMaybe (either (const Nothing) $ getEvidenceTree _rm) ns
423449
evNs = concatMap (map (Right . evidenceVar) . T.flatten) evTrees
424450
zeroPos = Position 0 0
425451
zeroRange = Range zeroPos zeroPos
426452
modToLocation m = fmap (\fs -> pure (Location (fromNormalizedUri $ filePathToUri' fs) zeroRange)) $ M.lookup m imports
427-
in fmap (nubOrd . concat) $ mapMaybeM
453+
in fmap (fmap fst . nubOrd . concat) $ mapMaybeM
428454
(either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m)))
429455
(\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n)))
430-
(ns ++ evNs)
456+
evNs
431457

432458
-- | Given a 'Name' attempt to find the location where it is defined.
433459
nameToLocation :: MonadIO m => WithHieDb -> LookupModule m -> Name -> m (Maybe [Location])

‎ghcide/test/exe/FindDefinitionAndHoverTests.hs

+20-1
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ import Language.LSP.Test
1313
import System.Info.Extra (isWindows)
1414

1515
import Config
16+
import Control.Category ((>>>))
1617
import Control.Lens ((^.))
1718
import Development.IDE.Test (expectDiagnostics,
1819
standardizeQuotes)
@@ -53,7 +54,25 @@ tests = let
5354
_ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover
5455

5556
extractLineColFromHoverMsg :: T.Text -> [T.Text]
56-
extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":")
57+
extractLineColFromHoverMsg =
58+
-- Hover messages contain multiple lines, and we are looking for the definition
59+
-- site
60+
T.lines
61+
-- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*"
62+
-- So filter by the start of the line
63+
>>> mapMaybe (T.stripPrefix "*Defined at")
64+
-- We assume for now, there can only be one such line.
65+
>>> head
66+
-- [" /tmp/", "22:3*"]
67+
>>> T.splitOn (sourceFileName <> ":")
68+
-- "22:3*"
69+
>>> last
70+
-- ["22:3", ""]
71+
>>> T.splitOn "*"
72+
-- "22:3"
73+
>>> head
74+
-- ["22", "3"]
75+
>>> T.splitOn ":"
5776

5877
checkHoverRange :: Range -> Maybe Range -> T.Text -> Session ()
5978
checkHoverRange expectedRange rangeInHover msg =

‎ghcide/test/exe/InitializeResponseTests.hs

+1-3
Original file line numberDiff line numberDiff line change
@@ -33,9 +33,7 @@ tests = withResource acquire release tests where
3333
, chk "NO signature help" _signatureHelpProvider Nothing
3434
, chk " goto definition" _definitionProvider (Just $ InR (DefinitionOptions (Just False)))
3535
, chk " goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False))))
36-
-- BUG in lsp-test, this test fails, just change the accepted response
37-
-- for now
38-
, chk "NO goto implementation" _implementationProvider Nothing
36+
, chk " goto implementation" _implementationProvider (Just $ InR (InL (ImplementationOptions (Just False))))
3937
, chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False)))
4038
, chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False)))
4139
, chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing))

‎hls-plugin-api/src/Ide/Types.hs

+8
Original file line numberDiff line numberDiff line change
@@ -504,6 +504,9 @@ instance PluginMethod Request Method_TextDocumentDefinition where
504504
instance PluginMethod Request Method_TextDocumentTypeDefinition where
505505
handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
506506

507+
instance PluginMethod Request Method_TextDocumentImplementation where
508+
handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
509+
507510
instance PluginMethod Request Method_TextDocumentDocumentHighlight where
508511
handlesRequest _ msgParams pluginDesc _ = pluginSupportsFileType msgParams pluginDesc
509512

@@ -697,6 +700,11 @@ instance PluginRequestMethod Method_TextDocumentTypeDefinition where
697700
| Just (Just True) <- caps ^? (L.textDocument . _Just . L.typeDefinition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs
698701
| otherwise = downgradeLinks $ foldl' mergeDefinitions x xs
699702

703+
instance PluginRequestMethod Method_TextDocumentImplementation where
704+
combineResponses _ _ caps _ (x :| xs)
705+
| Just (Just True) <- caps ^? (L.textDocument . _Just . L.typeDefinition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs
706+
| otherwise = downgradeLinks $ foldl' mergeDefinitions x xs
707+
700708
instance PluginRequestMethod Method_TextDocumentDocumentHighlight where
701709

702710
instance PluginRequestMethod Method_TextDocumentReferences where

0 commit comments

Comments
 (0)