Skip to content

Commit dde25d1

Browse files
JiriLojdaJiriLojda
committed
Downgrade locations to links when missing client capability in combineResponses (plugin API)
- Upgrade locations to links only when necessary (some responses are links)
1 parent 2e1d118 commit dde25d1

File tree

2 files changed

+108
-26
lines changed

2 files changed

+108
-26
lines changed

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

Lines changed: 26 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -6,13 +6,15 @@
66
{-# LANGUAGE DeriveAnyClass #-}
77
{-# LANGUAGE DeriveGeneric #-}
88
{-# LANGUAGE DerivingStrategies #-}
9+
{-# LANGUAGE DuplicateRecordFields #-}
910
{-# LANGUAGE FlexibleContexts #-}
1011
{-# LANGUAGE FlexibleInstances #-}
1112
{-# LANGUAGE GADTs #-}
1213
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1314
{-# LANGUAGE MonadComprehensions #-}
1415
{-# LANGUAGE MultiParamTypeClasses #-}
1516
{-# LANGUAGE NamedFieldPuns #-}
17+
{-# LANGUAGE OverloadedRecordDot #-}
1618
{-# LANGUAGE OverloadedStrings #-}
1719
{-# LANGUAGE PatternSynonyms #-}
1820
{-# LANGUAGE PolyKinds #-}
@@ -569,10 +571,14 @@ instance PluginRequestMethod Method_CodeActionResolve where
569571
combineResponses _ _ _ _ (x :| _) = x
570572

571573
instance PluginRequestMethod Method_TextDocumentDefinition where
572-
combineResponses _ _ _ _ (x :| xs) = foldl' mergeDefinitions x xs
574+
combineResponses _ _ caps _ (x :| xs)
575+
| Just True <- caps._textDocument >>= (._definition) >>= (._linkSupport) = foldl' mergeDefinitions x xs
576+
| otherwise = downgradeLinks $ foldl' mergeDefinitions x xs
573577

574578
instance PluginRequestMethod Method_TextDocumentTypeDefinition where
575-
combineResponses _ _ _ _ (x :| xs) = foldl' mergeDefinitions x xs
579+
combineResponses _ _ caps _ (x :| xs)
580+
| Just True <- caps._textDocument >>= (._typeDefinition) >>= (._linkSupport) = foldl' mergeDefinitions x xs
581+
| otherwise = downgradeLinks $ foldl' mergeDefinitions x xs
576582

577583
instance PluginRequestMethod Method_TextDocumentDocumentHighlight where
578584

@@ -698,11 +704,11 @@ type Definitions = (Definition |? ([DefinitionLink] |? Null))
698704

699705
mergeDefinitions :: Definitions -> Definitions -> Definitions
700706
mergeDefinitions definitions1 definitions2 = case (definitions1, definitions2) of
701-
(InR (InR Null), def2) -> def2
702-
(def1, InR (InR Null)) -> def1
703-
(InL def1, InL def2) -> InR $ InL (defToLinks def1 ++ defToLinks def2)
704-
(InL def1, InR (InL links)) -> InR $ InL (defToLinks def1 ++ links)
705-
(InR (InL links), InL def2) -> InR $ InL (links ++ defToLinks def2)
707+
(InR (InR Null), def2) -> def2
708+
(def1, InR (InR Null)) -> def1
709+
(InL def1, InL def2) -> InL $ mergeDefs def1 def2
710+
(InL def1, InR (InL links)) -> InR $ InL (defToLinks def1 ++ links)
711+
(InR (InL links), InL def2) -> InR $ InL (links ++ defToLinks def2)
706712
(InR (InL links1), InR (InL links2)) -> InR $ InL (links1 ++ links2)
707713
where
708714
defToLinks :: Definition -> [DefinitionLink]
@@ -711,6 +717,19 @@ mergeDefinitions definitions1 definitions2 = case (definitions1, definitions2) o
711717

712718
locationToLocationLink :: Location -> LocationLink
713719
locationToLocationLink Location{_uri, _range} = LocationLink{_originSelectionRange = Nothing, _targetUri = _uri, _targetRange = _range, _targetSelectionRange = _range}
720+
721+
mergeDefs :: Definition -> Definition -> Definition
722+
mergeDefs (Definition (InL loc1)) (Definition (InL loc2)) = Definition $ InR [loc1, loc2]
723+
mergeDefs (Definition (InR locs1)) (Definition (InL loc2)) = Definition $ InR (locs1 ++ [loc2])
724+
mergeDefs (Definition (InL loc1)) (Definition (InR locs2)) = Definition $ InR (loc1 : locs2)
725+
mergeDefs (Definition (InR locs1)) (Definition (InR locs2)) = Definition $ InR (locs1 ++ locs2)
726+
727+
downgradeLinks :: Definitions -> Definitions
728+
downgradeLinks (InR (InL links)) = InL . Definition . InR . map linkToLocation $ links
729+
where
730+
linkToLocation :: DefinitionLink -> Location
731+
linkToLocation (DefinitionLink LocationLink{_targetUri, _targetRange}) = Location {_uri = _targetUri, _range = _targetRange}
732+
downgradeLinks defs = defs
714733
-- ---------------------------------------------------------------------
715734
-- Plugin Notifications
716735
-- ---------------------------------------------------------------------

‎hls-plugin-api/test/Ide/TypesTests.hs

Lines changed: 82 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,17 @@
1-
{-# LANGUAGE DerivingStrategies #-}
2-
{-# LANGUAGE DuplicateRecordFields #-}
3-
{-# LANGUAGE TypeOperators #-}
1+
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE DuplicateRecordFields #-}
3+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+
{-# LANGUAGE TypeOperators #-}
5+
46
module Ide.TypesTests
57
( tests
68
) where
7-
import Control.Lens ((?~))
9+
import Control.Lens (preview, (?~), (^?))
10+
import Control.Monad ((>=>))
811
import Data.Default (Default (def))
912
import Data.Function ((&))
1013
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
14+
import Data.Maybe (isJust)
1115
import qualified Data.Text as Text
1216
import Ide.Types (Config (Config),
1317
PluginRequestMethod (combineResponses))
@@ -26,11 +30,19 @@ import Language.LSP.Protocol.Types (ClientCapabilities,
2630
Range (Range),
2731
TextDocumentClientCapabilities (TextDocumentClientCapabilities, _definition),
2832
TextDocumentIdentifier (TextDocumentIdentifier),
33+
TypeDefinitionClientCapabilities (TypeDefinitionClientCapabilities, _dynamicRegistration, _linkSupport),
2934
TypeDefinitionParams (..),
30-
Uri (Uri), filePathToUri,
35+
Uri (Uri), _L, _R,
36+
_typeDefinition, filePathToUri,
3137
type (|?) (..))
3238
import Test.Tasty (TestTree, testGroup)
3339
import Test.Tasty.HUnit (assertBool, testCase, (@=?))
40+
import Test.Tasty.QuickCheck (ASCIIString (ASCIIString),
41+
Arbitrary (arbitrary), Gen,
42+
NonEmptyList (NonEmpty),
43+
arbitraryBoundedEnum, cover,
44+
listOf1, oneof, testProperty,
45+
(===))
3446

3547
tests :: TestTree
3648
tests = testGroup "PluginTypes"
@@ -50,21 +62,22 @@ combineResponsesTextDocumentTypeDefinitionTests :: TestTree
5062
combineResponsesTextDocumentTypeDefinitionTests = testGroup "TextDocumentTypeDefinition" $
5163
defAndTypeDefSharedTests SMethod_TextDocumentTypeDefinition typeDefinitionParams
5264

53-
defAndTypeDefSharedTests message params = [ testCase "merges all single location responses into one response with all locations and upgrades them into links (with link support)" $ do
65+
defAndTypeDefSharedTests message params =
66+
[ testCase "merges all single location responses into one response with all locations (without upgrading to links)" $ do
5467
let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))
5568
pluginResponses =
5669
(InL . Definition . InL . Location testFileUri $ range1) :|
5770
[ InL . Definition . InL . Location testFileUri $ range2
5871
, InL . Definition . InL . Location testFileUri $ range3
5972
]
6073

61-
result = combineResponses message def supportsLinkInDefinitionCaps params pluginResponses
74+
result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses
6275

6376
expectedResult :: Definition |? ([DefinitionLink] |? Null)
64-
expectedResult = InR . InL $
65-
[ DefinitionLink $ LocationLink Nothing testFileUri range1 range1
66-
, DefinitionLink $ LocationLink Nothing testFileUri range2 range2
67-
, DefinitionLink $ LocationLink Nothing testFileUri range3 range3
77+
expectedResult = InL . Definition . InR $
78+
[ Location testFileUri range1
79+
, Location testFileUri range2
80+
, Location testFileUri range3
6881
]
6982
expectedResult @=? result
7083

@@ -78,7 +91,7 @@ defAndTypeDefSharedTests message params = [ testCase "merges all single location
7891
]
7992
]
8093

81-
result = combineResponses message def supportsLinkInDefinitionCaps params pluginResponses
94+
result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses
8295

8396
expectedResult :: Definition |? ([DefinitionLink] |? Null)
8497
expectedResult = InR . InL $
@@ -96,7 +109,7 @@ defAndTypeDefSharedTests message params = [ testCase "merges all single location
96109
, InL . Definition . InR $ [Location testFileUri range3]
97110
]
98111

99-
result = combineResponses message def supportsLinkInDefinitionCaps params pluginResponses
112+
result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses
100113

101114
expectedResult :: Definition |? ([DefinitionLink] |? Null)
102115
expectedResult = InR . InL $
@@ -111,10 +124,10 @@ defAndTypeDefSharedTests message params = [ testCase "merges all single location
111124
pluginResponses =
112125
(InL . Definition . InL . Location testFileUri $ range1) :|
113126
[ InR . InR $ Null
114-
, InL . Definition . InR $ [Location testFileUri range3]
127+
, InR . InL $ [DefinitionLink $ LocationLink Nothing testFileUri range3 range3]
115128
]
116129

117-
result = combineResponses message def supportsLinkInDefinitionCaps params pluginResponses
130+
result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses
118131

119132
expectedResult :: Definition |? ([DefinitionLink] |? Null)
120133
expectedResult = InR . InL $
@@ -131,20 +144,33 @@ defAndTypeDefSharedTests message params = [ testCase "merges all single location
131144
, InR . InR $ Null
132145
]
133146

134-
result = combineResponses message def supportsLinkInDefinitionCaps params pluginResponses
147+
result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses
135148

136149
expectedResult :: Definition |? ([DefinitionLink] |? Null)
137150
expectedResult = InR . InR $ Null
138151
expectedResult @=? result
152+
153+
, testProperty "downgrades all locationLinks to locations when missing link support in capabilities" $ \(MkGeneratedNonEmpty responses) -> do
154+
let pluginResponses = fmap (\(MkGeneratedDefinition definition) -> definition) responses
155+
156+
result = combineResponses message def def params pluginResponses
157+
158+
cover 70 (any (isJust . (>>= (^? _L)) . (^? _R)) pluginResponses) "Has at least one response with links" $
159+
cover 10 (any (isJust . (^? _L)) pluginResponses) "Has at least one response with locations" $
160+
cover 10 (any (isJust . (>>= (^? _R)) . (^? _R)) pluginResponses) "Has at least one response with Null" $
161+
(isJust (result ^? _L) || isJust (result ^? _R >>= (^? _R))) === True
139162
]
140163

141164
(range1, range2, range3) = (Range (Position 3 0) $ Position 3 5, Range (Position 5 7) $ Position 5 13, Range (Position 24 30) $ Position 24 40)
142165

143-
supportsLinkInDefinitionCaps :: ClientCapabilities
144-
supportsLinkInDefinitionCaps = def & L.textDocument ?~ textDocumentCaps
166+
supportsLinkInAllDefinitionCaps :: ClientCapabilities
167+
supportsLinkInAllDefinitionCaps = def & L.textDocument ?~ textDocumentCaps
145168
where
146169
textDocumentCaps :: TextDocumentClientCapabilities
147-
textDocumentCaps = def { _definition = Just DefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing }}
170+
textDocumentCaps = def
171+
{ _definition = Just DefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing }
172+
, _typeDefinition = Just TypeDefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing }
173+
}
148174

149175
definitionParams :: DefinitionParams
150176
definitionParams = DefinitionParams
@@ -164,3 +190,40 @@ typeDefinitionParams = TypeDefinitionParams
164190

165191
testFileUri :: Uri
166192
testFileUri = filePathToUri "file://tester/Test.hs"
193+
194+
newtype GeneratedDefinition = MkGeneratedDefinition (Definition |? ([DefinitionLink] |? Null)) deriving newtype (Show)
195+
196+
instance Arbitrary GeneratedDefinition where
197+
arbitrary = MkGeneratedDefinition <$> oneof
198+
[ InL . Definition . InL <$> generateLocation
199+
, InL . Definition . InR <$> listOf1 generateLocation
200+
, InR . InL . map DefinitionLink <$> listOf1 generateLocationLink
201+
, pure . InR . InR $ Null
202+
]
203+
where
204+
generateLocation :: Gen Location
205+
generateLocation = do
206+
(LocationLink _ uri range _) <- generateLocationLink
207+
pure $ Location uri range
208+
209+
generateLocationLink :: Gen LocationLink
210+
generateLocationLink = LocationLink <$> generateMaybe generateRange <*> generateUri <*> generateRange <*> generateRange
211+
212+
generateMaybe :: Gen a -> Gen (Maybe a)
213+
generateMaybe gen = oneof [Just <$> gen, pure Nothing]
214+
215+
generateUri :: Gen Uri
216+
generateUri = do
217+
(ASCIIString str) <- arbitrary
218+
pure . Uri . Text.pack $ str
219+
220+
generateRange :: Gen Range
221+
generateRange = Range <$> generatePosition <*> generatePosition
222+
223+
generatePosition :: Gen Position
224+
generatePosition = Position <$> arbitraryBoundedEnum <*> arbitraryBoundedEnum
225+
226+
newtype GeneratedNonEmpty a = MkGeneratedNonEmpty (NonEmpty a) deriving newtype (Show)
227+
228+
instance Arbitrary a => Arbitrary (GeneratedNonEmpty a) where
229+
arbitrary = MkGeneratedNonEmpty <$> ((:|) <$> arbitrary <*> arbitrary)

0 commit comments

Comments
 (0)