diff --git a/hls-plugin-api.cabal b/hls-plugin-api.cabal --- a/hls-plugin-api.cabal +++ b/hls-plugin-api.cabal @@ -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 @@ -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 diff --git a/src/Ide/Plugin/RangeMap.hs b/src/Ide/Plugin/RangeMap.hs --- a/src/Ide/Plugin/RangeMap.hs +++ b/src/Ide/Plugin/RangeMap.hs @@ -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 diff --git a/src/Ide/PluginUtils.hs b/src/Ide/PluginUtils.hs --- a/src/Ide/PluginUtils.hs +++ b/src/Ide/PluginUtils.hs @@ -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 diff --git a/src/Ide/Types.hs b/src/Ide/Types.hs --- a/src/Ide/Types.hs +++ b/src/Ide/Types.hs @@ -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 = diff --git a/test/Ide/PluginUtilsTest.hs b/test/Ide/PluginUtilsTest.hs --- a/test/Ide/PluginUtilsTest.hs +++ b/test/Ide/PluginUtilsTest.hs @@ -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 ] diff --git a/test/Ide/TypesTests.hs b/test/Ide/TypesTests.hs new file mode 100644 --- /dev/null +++ b/test/Ide/TypesTests.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ]