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

- enables multiple plugins to provide Document(Type)Definition for the same message

Author: JiriLojda

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

@@ -13,7 +13,6 @@
 {-# LANGUAGE MonadComprehensions        #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NamedFieldPuns             #-}
-{-# LANGUAGE OverloadedLabels           #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE PolyKinds                  #-}
@@ -76,6 +75,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 +560,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 +569,10 @@ instance PluginRequestMethod Method_CodeActionResolve where
     combineResponses _ _ _ _ (x :| _) = x
 
 instance PluginRequestMethod Method_TextDocumentDefinition where
-  combineResponses _ _ _ _ (x :| _) = x
+    combineResponses _ _ _ _ (x :| xs) = foldl' mergeDefinitions x xs
 
 instance PluginRequestMethod Method_TextDocumentTypeDefinition where
-  combineResponses _ _ _ _ (x :| _) = x
+    combineResponses _ _ _ _ (x :| xs) = foldl' mergeDefinitions x xs
 
 instance PluginRequestMethod Method_TextDocumentDocumentHighlight where
 
@@ -693,6 +693,24 @@ 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))
+
+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) -> InR $ InL (defToLinks def1 ++ defToLinks 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)) = [DefinitionLink $ locationToLocationLink location]
+        defToLinks (Definition (InR locations)) = map (DefinitionLink . locationToLocationLink) locations
+
+        locationToLocationLink :: Location -> LocationLink
+        locationToLocationLink Location{_uri, _range} = LocationLink{_originSelectionRange = Just _range, _targetUri = _uri, _targetRange = _range, _targetSelectionRange = _range}
 -- ---------------------------------------------------------------------
 -- Plugin Notifications
 -- ---------------------------------------------------------------------
@@ -942,7 +960,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 =