From dacc0b7bcda6be0db8a485c552f06081f15e5921 Mon Sep 17 00:00:00 2001 From: Fendor Date: Sat, 17 Aug 2024 14:54:00 +0200 Subject: [PATCH] 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. --- ghcide/src/Development/IDE/Core/Actions.hs | 10 +++ .../Development/IDE/LSP/HoverDefinition.hs | 7 +- .../src/Development/IDE/Plugin/HLS/GhcIde.hs | 2 + ghcide/src/Development/IDE/Spans/AtPoint.hs | 65 ++++++++++++------- .../test/exe/FindDefinitionAndHoverTests.hs | 23 ++++++- ghcide/test/exe/InitializeResponseTests.hs | 4 +- hls-plugin-api/src/Ide/Types.hs | 8 +++ 7 files changed, 91 insertions(+), 28 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Actions.hs b/ghcide/src/Development/IDE/Core/Actions.hs index 12945b59cd..0d55a73120 100644 --- 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,15 @@ 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 + !pos' <- MaybeT (pure $ fromCurrentPosition mapping pos) + locs <- AtPoint.gotoImplementation withHieDb (lookupMod hiedbWriter) opts 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 index e4c20504e4..c1463d4c70 100644 --- 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 "Implementation" 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 index ec5c6bf84b..ada0f9e682 100644 --- 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 index 4dca1cba7b..3d3c182072 100644 --- 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 @@ -66,6 +67,7 @@ import Development.IDE.Types.Shake (WithHieDb) import HieDb hiding (pointCommand, withHieDb) import System.Directory (doesFileExist) +import Data.Either.Extra (eitherToMaybe) -- | Gives a Uri for the module, given the .hie file location and the the module info -- The Bool denotes if it is a boot module @@ -214,6 +216,19 @@ 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. +-- Goto Implementation for an overloaded function. +gotoImplementation + :: MonadIO m + => WithHieDb + -> LookupModule m + -> IdeOptions + -> HieAstResult + -> Position + -> MaybeT m [Location] +gotoImplementation withHieDb getHieFile ideOpts srcSpans pos + = lift $ instanceLocationsAtPoint withHieDb getHieFile ideOpts 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 want to print evidence variable using a readable tree structure. + | 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 @@ -352,7 +357,7 @@ atPoint IdeOptions{} (HAR _ (hf :: HieASTs a) rf _ (kind :: HieKind hietype)) (D printDets ospn (Just (src,_,mspn)) = pprSrc $$ text "at" <+> ppr spn where - -- Use the bind span if we have one, else use the occurence span + -- Use the bind span if we have one, else use the occurrence span spn = fromMaybe ospn mspn pprSrc = case src of -- Users don't know what HsWrappers are @@ -419,15 +424,31 @@ locationsAtPoint -> m [(Location, Identifier)] locationsAtPoint 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 (either (\m -> pure ((fmap $ fmap (,Left m)) (modToLocation m))) (\n -> fmap (fmap $ fmap (,Right n)) (nameToLocation withHieDb lookupModule n))) - (ns ++ evNs) + ns + +-- | Find 'Location's of a implementation definition at a specific point. +instanceLocationsAtPoint + :: forall m + . MonadIO m + => WithHieDb + -> LookupModule m + -> IdeOptions + -> Position + -> HieAstResult + -> m [Location] +instanceLocationsAtPoint withHieDb lookupModule _ideOptions pos (HAR _ ast _rm _ _) = + let ns = concat $ pointCommand ast pos (M.keys . getNodeIds) + evTrees = mapMaybe (eitherToMaybe >=> getEvidenceTree _rm) ns + evNs = concatMap (map (evidenceVar) . T.flatten) evTrees + in fmap (nubOrd . concat) $ mapMaybeM + (nameToLocation withHieDb lookupModule) + 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/FindDefinitionAndHoverTests.hs b/ghcide/test/exe/FindDefinitionAndHoverTests.hs index 63d8dd7ab7..75c1ba2372 100644 --- a/ghcide/test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide/test/exe/FindDefinitionAndHoverTests.hs @@ -13,6 +13,7 @@ import Language.LSP.Test import System.Info.Extra (isWindows) import Config +import Control.Category ((>>>)) import Control.Lens ((^.)) import Development.IDE.Test (expectDiagnostics, standardizeQuotes) @@ -53,7 +54,27 @@ tests = let _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + extractLineColFromHoverMsg = + -- Hover messages contain multiple lines, and we are looking for the definition + -- site + T.lines + -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*" + -- So filter by the start of the line + >>> mapMaybe (T.stripPrefix "*Defined at") + -- There can be multiple definitions per hover message! + -- See the test "field in record definition" for example. + -- The tests check against the last line that contains the above line. + >>> last + -- [" /tmp/", "22:3*"] + >>> T.splitOn (sourceFileName <> ":") + -- "22:3*" + >>> last + -- ["22:3", ""] + >>> T.splitOn "*" + -- "22:3" + >>> head + -- ["22", "3"] + >>> T.splitOn ":" checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () checkHoverRange expectedRange rangeInHover msg = diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index 6192a8aeed..f13344e368 100644 --- 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 index fac6cd6b6b..1384b450a7 100644 --- 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.implementation . _Just . L.linkSupport) = foldl' mergeDefinitions x xs + | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs + instance PluginRequestMethod Method_TextDocumentDocumentHighlight where instance PluginRequestMethod Method_TextDocumentReferences where