Add "Goto Implementation" LSP handler

fendor · fendor · commit dfb700207b73 · 2024-09-12T18:34:46.000+02:00
Adds the necessary instances for handling the request type
`Method_TextDocumentImplementation`.
Further, wire up the appropriate handlers for the "gotoImplementation"
request.
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,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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
