hls-plugin-api 2.4.0.0 → 2.5.0.0
raw patch · 7 files changed
+388/−25 lines, 7 filesdep ~hls-graphdep ~lspdep ~megaparsecnew-uploader
Dependency ranges changed: hls-graph, lsp, megaparsec
Files
- hls-plugin-api.cabal +22/−17
- src/Ide/Plugin/RangeMap.hs +2/−1
- src/Ide/PluginUtils.hs +14/−1
- src/Ide/Types.hs +49/−5
- test/Ide/PluginUtilsTest.hs +54/−1
- test/Ide/TypesTests.hs +245/−0
- test/Main.hs +2/−0
hls-plugin-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: hls-plugin-api-version: 2.4.0.0+version: 2.5.0.0 synopsis: Haskell Language Server API for plugin communication description: Please see the README on GitHub at <https://github.com/haskell/haskell-language-server#readme>@@ -34,15 +34,15 @@ 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 @@ , filepath , ghc , hashable- , hls-graph == 2.4.0.0+ , hls-graph == 2.5.0.0 , lens , lens-aeson- , lsp ^>=2.2+ , lsp ^>=2.3+ , megaparsec >=9.0 , mtl , opentelemetry >=0.4 , optparse-applicative@@ -75,7 +76,6 @@ , transformers , unliftio , unordered-containers- , megaparsec > 9 if os(windows) build-depends: Win32@@ -85,14 +85,13 @@ 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 @@ 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
src/Ide/Plugin/RangeMap.hs view
@@ -23,7 +23,8 @@ import Data.Foldable (foldl') import Development.IDE.Graph.Classes (NFData) import Language.LSP.Protocol.Types (Position,- Range (Range))+ Range (Range),+ isSubrangeOf) #ifdef USE_FINGERTREE import qualified HaskellWorks.Data.IntervalMap.FingerTree as IM #endif
src/Ide/PluginUtils.hs view
@@ -236,7 +236,20 @@ extractTextInRange :: Range -> T.Text -> T.Text extractTextInRange (Range (Position sl sc) (Position el ec)) s = newS where- focusLines = take (fromIntegral $ el - sl + 1) $ drop (fromIntegral sl) $ T.lines s+ focusLines =+ T.lines s+ -- NOTE: Always append an empty line to the end to ensure there are+ -- sufficient lines to take from.+ --+ -- There is a situation that when the end position is placed at the line+ -- below the last line, if we simply do `drop` and then `take`, there+ -- will be `el - sl` lines left, not `el - sl + 1` lines. And then+ -- the last line of code will be emptied unexpectedly.+ --+ -- For details, see https://github.com/haskell/haskell-language-server/issues/3847+ & (++ [""])+ & drop (fromIntegral sl)+ & take (fromIntegral $ el - sl + 1) -- NOTE: We have to trim the last line first to handle the single-line case newS = focusLines
src/Ide/Types.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -13,7 +14,6 @@ {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-}@@ -76,6 +76,7 @@ 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 @@ -- 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 @@ 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' (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 @@ -- 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 =
test/Ide/PluginUtilsTest.hs view
@@ -9,7 +9,8 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Ide.Plugin.RangeMap as RangeMap-import Ide.PluginUtils (positionInRange, unescape)+import Ide.PluginUtils (extractTextInRange,+ positionInRange, unescape) import Language.LSP.Protocol.Types (Position (..), Range (Range), UInt, isSubrangeOf) import Test.Tasty@@ -19,6 +20,7 @@ tests :: TestTree tests = testGroup "PluginUtils" [ unescapeTest+ , extractTextInRangeTest , localOption (QuickCheckMaxSize 10000) $ testProperty "RangeMap-List filtering identical" $ prop_rangemapListEq @Int@@ -41,6 +43,57 @@ , testCase "control characters should not be escaped" $ unescape "\"\\n\\t\"" @?= "\"\\n\\t\"" ]++extractTextInRangeTest :: TestTree+extractTextInRangeTest = testGroup "extractTextInRange"+ [ testCase "inline range" $+ extractTextInRange+ ( Range (Position 0 3) (Position 3 5) )+ src+ @?= T.intercalate "\n"+ [ "ule Main where"+ , ""+ , "main :: IO ()"+ , "main "+ ]+ , testCase "inline range with empty content" $+ extractTextInRange+ ( Range (Position 0 0) (Position 0 1) )+ emptySrc+ @?= ""+ , testCase "multiline range with empty content" $+ extractTextInRange+ ( Range (Position 0 0) (Position 1 0) )+ emptySrc+ @?= "\n"+ , testCase "multiline range" $+ extractTextInRange+ ( Range (Position 1 0) (Position 4 0) )+ src+ @?= T.unlines+ [ ""+ , "main :: IO ()"+ , "main = do"+ ]+ , testCase "multiline range with end pos at the line below the last line" $+ extractTextInRange+ ( Range (Position 2 0) (Position 5 0) )+ src+ @?= T.unlines+ [ "main :: IO ()"+ , "main = do"+ , " putStrLn \"hello, world\""+ ]+ ]+ where+ src = T.unlines+ [ "module Main where"+ , ""+ , "main :: IO ()"+ , "main = do"+ , " putStrLn \"hello, world\""+ ]+ emptySrc = "\n" genRange :: Gen Range genRange = oneof [ genRangeInline, genRangeMultiline ]
+ test/Ide/TypesTests.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Ide.TypesTests+ ( tests+ ) where+import Control.Lens (preview, (?~), (^?))+import Control.Monad ((>=>))+import Data.Default (Default (def))+import Data.Function ((&))+import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)+import Data.Maybe (isJust)+import qualified Data.Text as Text+import Ide.Types (Config (Config),+ PluginRequestMethod (combineResponses))+import qualified Language.LSP.Protocol.Lens as L+import Language.LSP.Protocol.Message (Method (Method_TextDocumentDefinition),+ SMethod (..))+import Language.LSP.Protocol.Types (ClientCapabilities,+ Definition (Definition),+ DefinitionClientCapabilities (DefinitionClientCapabilities, _dynamicRegistration, _linkSupport),+ DefinitionLink (DefinitionLink),+ DefinitionParams (DefinitionParams, _partialResultToken, _position, _textDocument, _workDoneToken),+ Location (Location),+ LocationLink (LocationLink),+ Null (Null),+ Position (Position),+ Range (Range),+ TextDocumentClientCapabilities (TextDocumentClientCapabilities, _definition),+ TextDocumentIdentifier (TextDocumentIdentifier),+ TypeDefinitionClientCapabilities (TypeDefinitionClientCapabilities, _dynamicRegistration, _linkSupport),+ TypeDefinitionParams (..),+ Uri (Uri), _L, _R,+ _typeDefinition, filePathToUri,+ type (|?) (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@=?))+import Test.Tasty.QuickCheck (ASCIIString (ASCIIString),+ Arbitrary (arbitrary), Gen,+ NonEmptyList (NonEmpty),+ arbitraryBoundedEnum, cover,+ listOf1, oneof, testProperty,+ (===))++tests :: TestTree+tests = testGroup "PluginTypes"+ [ combineResponsesTests ]++combineResponsesTests :: TestTree+combineResponsesTests = testGroup "combineResponses"+ [ combineResponsesTextDocumentDefinitionTests+ , combineResponsesTextDocumentTypeDefinitionTests+ ]++combineResponsesTextDocumentDefinitionTests :: TestTree+combineResponsesTextDocumentDefinitionTests = testGroup "TextDocumentDefinition" $+ defAndTypeDefSharedTests SMethod_TextDocumentDefinition definitionParams++combineResponsesTextDocumentTypeDefinitionTests :: TestTree+combineResponsesTextDocumentTypeDefinitionTests = testGroup "TextDocumentTypeDefinition" $+ defAndTypeDefSharedTests SMethod_TextDocumentTypeDefinition typeDefinitionParams++defAndTypeDefSharedTests message params =+ [ testCase "merges all single location responses into one response with all locations (without upgrading to links)" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InL . Definition . InL . Location testFileUri $ range1) :|+ [ InL . Definition . InL . Location testFileUri $ range2+ , InL . Definition . InL . Location testFileUri $ range3+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InL . Definition . InR $+ [ Location testFileUri range1+ , Location testFileUri range2+ , Location testFileUri range3+ ]+ expectedResult @=? result++ , testCase "merges all location link responses into one with all links (with link support)" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InR . InL $ [DefinitionLink $ LocationLink Nothing testFileUri range1 range1]) :|+ [ InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range2 range2+ , DefinitionLink $ LocationLink Nothing testFileUri range3 range3+ ]+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1+ , DefinitionLink $ LocationLink Nothing testFileUri range2 range2+ , DefinitionLink $ LocationLink Nothing testFileUri range3 range3+ ]+ expectedResult @=? result++ , testCase "merges location responses with link responses into link responses (with link support)" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InL . Definition . InL . Location testFileUri $ range1) :|+ [ InR . InL $ [ DefinitionLink $ LocationLink Nothing testFileUri range2 range2 ]+ , InL . Definition . InR $ [Location testFileUri range3]+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1+ , DefinitionLink $ LocationLink Nothing testFileUri range2 range2+ , DefinitionLink $ LocationLink Nothing testFileUri range3 range3+ ]+ expectedResult @=? result++ , testCase "preserves link-specific data when merging link and location responses (with link support)" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InL . Definition . InL . Location testFileUri $ range1) :|+ [ InR . InL $ [ DefinitionLink $ LocationLink (Just range1) testFileUri range2 range3 ] ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1+ , DefinitionLink $ LocationLink (Just range1) testFileUri range2 range3+ ]+ expectedResult @=? result++ , testCase "ignores Null responses when other responses are available" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InL . Definition . InL . Location testFileUri $ range1) :|+ [ InR . InR $ Null+ , InR . InL $ [DefinitionLink $ LocationLink Nothing testFileUri range3 range3]+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InL $+ [ DefinitionLink $ LocationLink Nothing testFileUri range1 range1+ , DefinitionLink $ LocationLink Nothing testFileUri range3 range3+ ]+ expectedResult @=? result++ , testCase "returns Null when all responses are Null" $ do+ let pluginResponses :: NonEmpty (Definition |? ([DefinitionLink] |? Null))+ pluginResponses =+ (InR . InR $ Null) :|+ [ InR . InR $ Null+ , InR . InR $ Null+ ]++ result = combineResponses message def supportsLinkInAllDefinitionCaps params pluginResponses++ expectedResult :: Definition |? ([DefinitionLink] |? Null)+ expectedResult = InR . InR $ Null+ expectedResult @=? result++ , testProperty "downgrades all locationLinks to locations when missing link support in capabilities" $ \(MkGeneratedNonEmpty responses) -> do+ let pluginResponses = fmap (\(MkGeneratedDefinition definition) -> definition) responses++ result = combineResponses message def def params pluginResponses++ cover 70 (any (isJust . (>>= (^? _L)) . (^? _R)) pluginResponses) "Has at least one response with links" $+ cover 10 (any (isJust . (^? _L)) pluginResponses) "Has at least one response with locations" $+ cover 10 (any (isJust . (>>= (^? _R)) . (^? _R)) pluginResponses) "Has at least one response with Null" $+ (isJust (result ^? _L) || isJust (result ^? _R >>= (^? _R))) === True+ ]++(range1, range2, range3) = (Range (Position 3 0) $ Position 3 5, Range (Position 5 7) $ Position 5 13, Range (Position 24 30) $ Position 24 40)++supportsLinkInAllDefinitionCaps :: ClientCapabilities+supportsLinkInAllDefinitionCaps = def & L.textDocument ?~ textDocumentCaps+ where+ textDocumentCaps :: TextDocumentClientCapabilities+ textDocumentCaps = def+ { _definition = Just DefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing }+ , _typeDefinition = Just TypeDefinitionClientCapabilities { _linkSupport = Just True, _dynamicRegistration = Nothing }+ }++definitionParams :: DefinitionParams+definitionParams = DefinitionParams+ { _textDocument = TextDocumentIdentifier testFileUri+ , _position = Position 5 4+ , _workDoneToken = Nothing+ , _partialResultToken = Nothing+ }++typeDefinitionParams :: TypeDefinitionParams+typeDefinitionParams = TypeDefinitionParams+ { _textDocument = TextDocumentIdentifier testFileUri+ , _position = Position 5 4+ , _workDoneToken = Nothing+ , _partialResultToken = Nothing+ }++testFileUri :: Uri+testFileUri = filePathToUri "file://tester/Test.hs"++newtype GeneratedDefinition = MkGeneratedDefinition (Definition |? ([DefinitionLink] |? Null)) deriving newtype (Show)++instance Arbitrary GeneratedDefinition where+ arbitrary = MkGeneratedDefinition <$> oneof+ [ InL . Definition . InL <$> generateLocation+ , InL . Definition . InR <$> listOf1 generateLocation+ , InR . InL . map DefinitionLink <$> listOf1 generateLocationLink+ , pure . InR . InR $ Null+ ]+ where+ generateLocation :: Gen Location+ generateLocation = do+ (LocationLink _ uri range _) <- generateLocationLink+ pure $ Location uri range++ generateLocationLink :: Gen LocationLink+ generateLocationLink = LocationLink <$> generateMaybe generateRange <*> generateUri <*> generateRange <*> generateRange++ generateMaybe :: Gen a -> Gen (Maybe a)+ generateMaybe gen = oneof [Just <$> gen, pure Nothing]++ generateUri :: Gen Uri+ generateUri = do+ (ASCIIString str) <- arbitrary+ pure . Uri . Text.pack $ str++ generateRange :: Gen Range+ generateRange = Range <$> generatePosition <*> generatePosition++ generatePosition :: Gen Position+ generatePosition = Position <$> arbitraryBoundedEnum <*> arbitraryBoundedEnum++newtype GeneratedNonEmpty a = MkGeneratedNonEmpty (NonEmpty a) deriving newtype (Show)++instance Arbitrary a => Arbitrary (GeneratedNonEmpty a) where+ arbitrary = MkGeneratedNonEmpty <$> ((:|) <$> arbitrary <*> arbitrary)
test/Main.hs view
@@ -1,6 +1,7 @@ module Main where import qualified Ide.PluginUtilsTest as PluginUtilsTest+import qualified Ide.TypesTests as PluginTypesTests import Test.Tasty import Test.Tasty.Ingredients.Rerun @@ -10,4 +11,5 @@ tests :: TestTree tests = testGroup "Main" [ PluginUtilsTest.tests+ , PluginTypesTests.tests ]