Merge definitions from all plugins for Document(Type)Definition message

ghcide/test/exe/TestUtils.hs

@@ -210,7 +210,7 @@ knownIssueFor solution = go . \case
         go True = case solution of
             Broken -> expectFailBecause
             Ignore -> ignoreTestBecause
-        go False = \_ -> id
+        go False = const id
 
 data Expect
   = ExpectRange Range -- Both gotoDef and hover should report this range
@@ -278,21 +278,22 @@ pattern R x y x' y' = Range (Position x y) (Position x' y')
 checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session ()
 checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where
   check (ExpectRange expectedRange) = do
-    assertNDefinitionsFound 1 defs
-    assertRangeCorrect (head defs) expectedRange
+    def <- assertOneDefinitionFound defs
+    assertRangeCorrect def expectedRange
   check (ExpectLocation expectedLocation) = do
-    assertNDefinitionsFound 1 defs
+    def <- assertOneDefinitionFound defs
     liftIO $ do
-      canonActualLoc <- canonicalizeLocation (head defs)
+      canonActualLoc <- canonicalizeLocation def
       canonExpectedLoc <- canonicalizeLocation expectedLocation
       canonActualLoc @?= canonExpectedLoc
   check ExpectNoDefinitions = do
-    assertNDefinitionsFound 0 defs
+    liftIO $ assertBool "Expecting no definitions" $ null defs
   check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file"
   check _ = pure () -- all other expectations not relevant to getDefinition
 
-  assertNDefinitionsFound :: Int -> [a] -> Session ()
-  assertNDefinitionsFound n defs = liftIO $ assertEqual "number of definitions" n (length defs)
+  assertOneDefinitionFound :: [Location] -> Session Location
+  assertOneDefinitionFound [def] = pure def
+  assertOneDefinitionFound _ = liftIO $ assertFailure "Expecting exactly one definition"
 
   assertRangeCorrect Location{_range = foundRange} expectedRange =
     liftIO $ expectedRange @=? foundRange

hls-plugin-api/hls-plugin-api.cabal

@@ -34,15 +34,15 @@ source-repository head
 
 library
   exposed-modules:
-    Ide.Plugin.Error
+    Ide.Logger
     Ide.Plugin.Config
     Ide.Plugin.ConfigUtils
+    Ide.Plugin.Error
     Ide.Plugin.Properties
     Ide.Plugin.RangeMap
     Ide.Plugin.Resolve
     Ide.PluginUtils
     Ide.Types
-    Ide.Logger
 
   hs-source-dirs:     src
   build-depends:
@@ -59,10 +59,11 @@ library
     , filepath
     , ghc
     , hashable
-    , hls-graph             == 2.4.0.0
+    , hls-graph             ==2.4.0.0
     , lens
     , lens-aeson
     , lsp                   ^>=2.2
+    , megaparsec            >=9.0
     , mtl
     , opentelemetry         >=0.4
     , optparse-applicative
@@ -75,7 +76,6 @@ library
     , transformers
     , unliftio
     , unordered-containers
-    , megaparsec > 9
 
   if os(windows)
     build-depends: Win32
@@ -85,14 +85,13 @@ library
 
   ghc-options:
     -Wall -Wredundant-constraints -Wno-name-shadowing
-    -Wno-unticked-promoted-constructors
-    -Wunused-packages
+    -Wno-unticked-promoted-constructors -Wunused-packages
 
   if flag(pedantic)
     ghc-options: -Werror
 
   if flag(use-fingertree)
-    cpp-options: -DUSE_FINGERTREE
+    cpp-options:   -DUSE_FINGERTREE
     build-depends: hw-fingertree
 
   default-language:   Haskell2010
@@ -107,33 +106,39 @@ test-suite tests
   hs-source-dirs:   test
   main-is:          Main.hs
   ghc-options:      -threaded -rtsopts -with-rtsopts=-N
-  other-modules:    Ide.PluginUtilsTest
+  other-modules:
+    Ide.PluginUtilsTest
+    Ide.TypesTests
+
   build-depends:
-      base
+    , base
+    , containers
+    , data-default
     , hls-plugin-api
+    , lens
+    , lsp-types
     , tasty
     , tasty-hunit
-    , tasty-rerun
     , tasty-quickcheck
+    , tasty-rerun
     , text
-    , lsp-types
-    , containers
 
 benchmark rangemap-benchmark
   -- Benchmark doesn't make sense if fingertree implementation
   -- is not used.
   if !flag(use-fingertree)
     buildable: False
+
   type:             exitcode-stdio-1.0
   default-language: Haskell2010
   hs-source-dirs:   bench
   main-is:          Main.hs
   ghc-options:      -threaded -Wall
   build-depends:
-      base
+    , base
+    , criterion
+    , deepseq
     , hls-plugin-api
     , lsp-types
-    , criterion
     , random
     , random-fu
-    , deepseq

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

@@ -6,14 +6,14 @@
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE DuplicateRecordFields      #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MonadComprehensions        #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NamedFieldPuns             #-}
-{-# LANGUAGE OverloadedLabels           #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE PolyKinds                  #-}
@@ -76,6 +76,7 @@ import           Data.Default
 import           Data.Dependent.Map            (DMap)
 import qualified Data.Dependent.Map            as DMap
 import qualified Data.DList                    as DList
+import           Data.Foldable                 (foldl')
 import           Data.GADT.Compare
 import           Data.Hashable                 (Hashable)
 import           Data.HashMap.Strict           (HashMap)
@@ -560,7 +561,7 @@ instance PluginRequestMethod Method_TextDocumentCodeAction where
         -- should check whether the requested kind is a *prefix* of the action kind.
         -- That means, for example, we will return actions with kinds `quickfix.import` and
         -- `quickfix.somethingElse` if the requested kind is `quickfix`.
-        , Just caKind <- ca ^. L.kind = any (\k -> k `codeActionKindSubsumes` caKind) allowed
+        , Just caKind <- ca ^. L.kind = any (`codeActionKindSubsumes` caKind) allowed
         | otherwise = False
 
 instance PluginRequestMethod Method_CodeActionResolve where
@@ -569,10 +570,14 @@ instance PluginRequestMethod Method_CodeActionResolve where
     combineResponses _ _ _ _ (x :| _) = x
 
 instance PluginRequestMethod Method_TextDocumentDefinition where
-  combineResponses _ _ _ _ (x :| _) = x
+    combineResponses _ _ caps _ (x :| xs)
+        | Just (Just True) <- caps ^? (L.textDocument . _Just . L.definition . _Just . L.linkSupport) = foldl' mergeDefinitions x xs
+        | otherwise = downgradeLinks $ foldl' mergeDefinitions x xs
 
 instance PluginRequestMethod Method_TextDocumentTypeDefinition where
-  combineResponses _ _ _ _ (x :| _) = x
+    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
 
@@ -693,6 +698,45 @@ nullToMaybe' :: (a |? (b |? Null)) -> Maybe (a |? b)
 nullToMaybe' (InL x)       = Just $ InL x
 nullToMaybe' (InR (InL x)) = Just $ InR x
 nullToMaybe' (InR (InR _)) = Nothing
+
+type Definitions = (Definition |? ([DefinitionLink] |? Null))
+
+-- | Merges two definition responses (TextDocumentDefinition | TextDocumentTypeDefinition)
+-- into one preserving all locations and their order (including order of the responses).
+-- Upgrades Location(s) into LocationLink(s) when one of the responses is LocationLink(s). With following fields:
+--  * LocationLink.originSelectionRange = Nothing
+--  * LocationLink.targetUri = Location.Uri
+--  * LocationLink.targetRange = Location.Range
+--  * LocationLink.targetSelectionRange = Location.Range
+-- Ignores Null responses.
+mergeDefinitions :: Definitions -> Definitions -> Definitions
+mergeDefinitions definitions1 definitions2 = case (definitions1, definitions2) of
+    (InR (InR Null), def2)               -> def2
+    (def1, InR (InR Null))               -> def1
+    (InL def1, InL def2)                 -> InL $ mergeDefs def1 def2
+    (InL def1, InR (InL links))          -> InR $ InL (defToLinks def1 ++ links)
+    (InR (InL links), InL def2)          -> InR $ InL (links ++ defToLinks def2)
+    (InR (InL links1), InR (InL links2)) -> InR $ InL (links1 ++ links2)
+    where
+        defToLinks :: Definition -> [DefinitionLink]
+        defToLinks (Definition (InL location)) = [locationToDefinitionLink location]
+        defToLinks (Definition (InR locations)) = map locationToDefinitionLink locations
+
+        locationToDefinitionLink :: Location -> DefinitionLink
+        locationToDefinitionLink Location{_uri, _range} = DefinitionLink LocationLink{_originSelectionRange = Nothing, _targetUri = _uri, _targetRange = _range, _targetSelectionRange = _range}
+
+        mergeDefs :: Definition -> Definition -> Definition
+        mergeDefs (Definition (InL loc1)) (Definition (InL loc2)) = Definition $ InR [loc1, loc2]
+        mergeDefs (Definition (InR locs1)) (Definition (InL loc2)) = Definition $ InR (locs1 ++ [loc2])
+        mergeDefs (Definition (InL loc1)) (Definition (InR locs2)) = Definition $ InR (loc1 : locs2)
+        mergeDefs (Definition (InR locs1)) (Definition (InR locs2)) = Definition $ InR (locs1 ++ locs2)
+
+downgradeLinks :: Definitions -> Definitions
+downgradeLinks (InR (InL links)) = InL . Definition . InR . map linkToLocation $ links
+    where
+        linkToLocation :: DefinitionLink -> Location
+        linkToLocation (DefinitionLink LocationLink{_targetUri, _targetRange}) = Location {_uri = _targetUri, _range = _targetRange}
+downgradeLinks defs = defs
 -- ---------------------------------------------------------------------
 -- Plugin Notifications
 -- ---------------------------------------------------------------------
@@ -942,7 +986,7 @@ mkResolveHandler m f = mkPluginHandler m $ \ideState plId params -> do
     -- as this is filtered out in `pluginEnabled`
     _ -> throwError $ PluginInternalError invalidRequest
   where invalidRequest = "The resolve request incorrectly got routed to the wrong resolve handler!"
-        parseError value err = "Unable to decode: " <> (T.pack $ show value) <> ". Error: " <> (T.pack $ show err)
+        parseError value err = "Unable to decode: " <> T.pack (show value) <> ". Error: " <> T.pack (show err)
 
 wrapResolveData :: L.HasData_ a (Maybe Value) => PluginId -> Uri -> a -> a
 wrapResolveData pid uri hasData =