diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Revision history for lsp +## 1.2.0.1 + +* Add exception instances to LspT (#315) (@pepeiborra) +* Add call hierarchy support (@July541) +* Fix build on GHC 9 (@anka-213) +* pass the lspConfig at initialization time as well (@pepeiborra) +* Semantic token (@michaelpj) +* Do not crash on workspace/didChangeConfiguration (#321) (@strager) + ## 1.2.0.0 * Parse config from initializeOptions and pass in the old value of config to onConfigurationChange (#285) (wz1000) diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -1,14 +1,14 @@ cabal-version: 2.2 name: lsp -version: 1.2.0.0 +version: 1.2.0.1 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to allow language implementors to support the Language Server Protocol for their specific language. . - An example of this is for Haskell via the Haskell IDE - Engine, at https://github.com/haskell/haskell-ide-engine + An example of this is for Haskell via the Haskell Language + Server, at https://github.com/haskell/haskell-language-server homepage: https://github.com/haskell/lsp license: MIT @@ -31,18 +31,17 @@ , Language.LSP.Server.Control , Language.LSP.Server.Processing ghc-options: -Wall - build-depends: base >= 4.11 && < 4.15 + build-depends: base >= 4.11 && < 4.16 , async , aeson >=1.0.0.0 , attoparsec , bytestring , containers - , directory , data-default - , filepath + , exceptions , hslogger , hashable - , lsp-types == 1.2.* + , lsp-types == 1.3.* , dependent-map , lens >= 4.15.2 , mtl @@ -68,7 +67,7 @@ default-language: Haskell2010 ghc-options: -Wall -Wno-unticked-promoted-constructors - build-depends: base >= 4.11 && < 4.15 + build-depends: base >= 4.11 && < 4.16 , aeson , bytestring , containers @@ -115,6 +114,7 @@ DiagnosticsSpec MethodSpec ServerCapabilitiesSpec + SemanticTokensSpec TypesSpec URIFilePathSpec VspSpec @@ -122,12 +122,8 @@ build-depends: base , QuickCheck , aeson - , bytestring , containers - , data-default - , directory , filepath - , hashable , lsp , hspec -- , hspec-jenkins @@ -136,7 +132,6 @@ , quickcheck-instances , rope-utf16-splay >= 0.2 , sorted-list == 0.2.1.* - , stm , text , unordered-containers -- For GHCI tests diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -67,6 +67,7 @@ import qualified System.Log.Logger as L import System.Random hiding (next) import Control.Monad.Trans.Identity +import Control.Monad.Catch (MonadMask, MonadCatch, MonadThrow) -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-} @@ -75,7 +76,7 @@ -- --------------------------------------------------------------------- newtype LspT config m a = LspT { unLspT :: ReaderT (LanguageContextEnv config) m a } - deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadUnliftIO, MonadFix) + deriving (Functor, Applicative, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans, MonadUnliftIO, MonadFix) -- for deriving the instance of MonadUnliftIO type role LspT representational representational nominal @@ -127,7 +128,7 @@ -- notificationHandler SInitialized $ \notif -> pure () -- , requestHandler STextDocumentHover $ \req responder -> pure () -- ] --- @ +-- @ data Handlers m = Handlers { reqHandlers :: !(DMap SMethod (ClientMessageHandler m Request)) @@ -306,7 +307,7 @@ -- The handlers here cannot be unregistered during the server's lifetime -- and will be regsitered statically in the initialize request. , interpretHandler :: a -> (m <~> IO) - -- ^ How to run the handlers in your own monad of choice, @m@. + -- ^ How to run the handlers in your own monad of choice, @m@. -- It is passed the result of 'doInitialize', so typically you will want -- to thread along the 'LanguageContextEnv' as well as any other state you -- need to run your monad. @m@ should most likely be built on top of @@ -315,7 +316,7 @@ -- @ -- ServerDefinition { ... -- , doInitialize = \env _req -> pure $ Right env - -- , interpretHandler = \env -> Iso + -- , interpretHandler = \env -> Iso -- (runLspT env) -- how to convert from IO ~> m -- liftIO -- how to convert from m ~> IO -- } @@ -473,7 +474,7 @@ clientCaps <- getClientCapabilities let clientSupportsWfs = fromMaybe False $ do let (J.ClientCapabilities mw _ _ _) = clientCaps - (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _) <- mw + (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _ _) <- mw mwf if clientSupportsWfs then Just <$> getsState resWorkspaceFolders @@ -534,35 +535,37 @@ -- | Checks if client capabilities declares that the method supports dynamic registration dynamicSupported clientCaps = case method of - SWorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just - SWorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just - SWorkspaceSymbol -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just - SWorkspaceExecuteCommand -> capDyn $ clientCaps ^? J.workspace . _Just . J.executeCommand . _Just - STextDocumentDidOpen -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentDidChange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentDidClose -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentCompletion -> capDyn $ clientCaps ^? J.textDocument . _Just . J.completion . _Just - STextDocumentHover -> capDyn $ clientCaps ^? J.textDocument . _Just . J.hover . _Just - STextDocumentSignatureHelp -> capDyn $ clientCaps ^? J.textDocument . _Just . J.signatureHelp . _Just - STextDocumentDeclaration -> capDyn $ clientCaps ^? J.textDocument . _Just . J.declaration . _Just - STextDocumentDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.definition . _Just - STextDocumentTypeDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.typeDefinition . _Just - STextDocumentImplementation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.implementation . _Just - STextDocumentReferences -> capDyn $ clientCaps ^? J.textDocument . _Just . J.references . _Just - STextDocumentDocumentHighlight -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentHighlight . _Just - STextDocumentDocumentSymbol -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentSymbol . _Just - STextDocumentCodeAction -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeAction . _Just - STextDocumentCodeLens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeLens . _Just - STextDocumentDocumentLink -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentLink . _Just - STextDocumentDocumentColor -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just - STextDocumentColorPresentation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just - STextDocumentFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.formatting . _Just - STextDocumentRangeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rangeFormatting . _Just - STextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.onTypeFormatting . _Just - STextDocumentRename -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rename . _Just - STextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just - STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just - _ -> False + SWorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just + SWorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just + SWorkspaceSymbol -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just + SWorkspaceExecuteCommand -> capDyn $ clientCaps ^? J.workspace . _Just . J.executeCommand . _Just + STextDocumentDidOpen -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentDidChange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentDidClose -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just + STextDocumentCompletion -> capDyn $ clientCaps ^? J.textDocument . _Just . J.completion . _Just + STextDocumentHover -> capDyn $ clientCaps ^? J.textDocument . _Just . J.hover . _Just + STextDocumentSignatureHelp -> capDyn $ clientCaps ^? J.textDocument . _Just . J.signatureHelp . _Just + STextDocumentDeclaration -> capDyn $ clientCaps ^? J.textDocument . _Just . J.declaration . _Just + STextDocumentDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.definition . _Just + STextDocumentTypeDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.typeDefinition . _Just + STextDocumentImplementation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.implementation . _Just + STextDocumentReferences -> capDyn $ clientCaps ^? J.textDocument . _Just . J.references . _Just + STextDocumentDocumentHighlight -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentHighlight . _Just + STextDocumentDocumentSymbol -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentSymbol . _Just + STextDocumentCodeAction -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeAction . _Just + STextDocumentCodeLens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeLens . _Just + STextDocumentDocumentLink -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentLink . _Just + STextDocumentDocumentColor -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just + STextDocumentColorPresentation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just + STextDocumentFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.formatting . _Just + STextDocumentRangeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rangeFormatting . _Just + STextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.onTypeFormatting . _Just + STextDocumentRename -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rename . _Just + STextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just + STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just + STextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? J.textDocument . _Just . J.callHierarchy . _Just + STextDocumentSemanticTokens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.semanticTokens . _Just + _ -> False -- | Sends a @client/unregisterCapability@ request and removes the handler -- for that associated registration. @@ -683,7 +686,7 @@ if clientSupportsProgress clientCaps then withProgressBase True title cancellable (const f) else f - + -- --------------------------------------------------------------------- -- | Aggregate all diagnostics pertaining to a particular version of a document, diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs --- a/src/Language/LSP/Server/Processing.hs +++ b/src/Language/LSP/Server/Processing.hs @@ -33,13 +33,13 @@ import Control.Monad.Trans.Except import Control.Monad.Reader import Data.IxMap -import System.Directory import System.Log.Logger import qualified Data.Dependent.Map as DMap import Data.Maybe import Data.Dependent.Map (DMap) import qualified Data.Map.Strict as Map import System.Exit +import Data.Default (def) processMessage :: BSL.ByteString -> LspM config () processMessage jsonStr = do @@ -87,12 +87,6 @@ rootDir = getFirst $ foldMap First [ params ^. LSP.rootUri >>= uriToFilePath , params ^. LSP.rootPath <&> T.unpack ] - liftIO $ case rootDir of - Nothing -> return () - Just dir -> do - debugM "lsp.initializeRequestHandler" $ "Setting current dir to project root:" ++ dir - unless (null dir) $ setCurrentDirectory dir - let initialWfs = case params ^. LSP.workspaceFolders of Just (List xs) -> xs Nothing -> [] @@ -128,7 +122,7 @@ where makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) - + initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a) initializeErrorHandler sendResp e = do sendResp $ ResponseError InternalError msg Nothing @@ -169,6 +163,8 @@ , _foldingRangeProvider = supportedBool STextDocumentFoldingRange , _executeCommandProvider = executeCommandProvider , _selectionRangeProvider = supportedBool STextDocumentSelectionRange + , _callHierarchyProvider = supportedBool STextDocumentPrepareCallHierarchy + , _semanticTokensProvider = semanticTokensProvider , _workspaceSymbolProvider = supported SWorkspaceSymbol , _workspace = Just workspace -- TODO: Add something for experimental @@ -251,6 +247,16 @@ InR . RenameOptions Nothing . Just $ True | supported_b STextDocumentRename = Just (InL True) | otherwise = Just (InL False) + + -- Always provide the default legend + -- TODO: allow user-provided legend via 'Options', or at least user-provided types + semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing def semanticTokenRangeProvider semanticTokenFullProvider + semanticTokenRangeProvider + | supported_b STextDocumentSemanticTokensRange = Just $ SemanticTokensRangeBool True + | otherwise = Nothing + semanticTokenFullProvider + | supported_b STextDocumentSemanticTokensFull = Just $ SemanticTokensFullDelta $ SemanticTokensDeltaClientCapabilities $ supported STextDocumentSemanticTokensFullDelta + | otherwise = Nothing sync = case textDocumentSync o of Just x -> Just (InL x) diff --git a/test/MethodSpec.hs b/test/MethodSpec.hs --- a/test/MethodSpec.hs +++ b/test/MethodSpec.hs @@ -31,6 +31,7 @@ ,"workspace/didChangeWatchedFiles" ,"workspace/symbol" ,"workspace/executeCommand" + ,"workspace/semanticTokens/refresh" -- Document ,"textDocument/didOpen" ,"textDocument/didChange" @@ -56,6 +57,14 @@ ,"documentLink/resolve" ,"textDocument/rename" ,"textDocument/prepareRename" + ,"textDocument/prepareCallHierarchy" + ,"callHierarchy/incomingCalls" + ,"callHierarchy/outgoingCalls" + + ,"textDocument/semanticTokens" + ,"textDocument/semanticTokens/full" + ,"textDocument/semanticTokens/full/delta" + ,"textDocument/semanticTokens/range" ] serverMethods :: [T.Text] diff --git a/test/SemanticTokensSpec.hs b/test/SemanticTokensSpec.hs new file mode 100644 --- /dev/null +++ b/test/SemanticTokensSpec.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +module SemanticTokensSpec where + +import Test.Hspec +import Language.LSP.Types +import Data.List (unfoldr) +import Data.Either (isRight) + +spec :: Spec +spec = do + let exampleLegend = SemanticTokensLegend (List [SttProperty, SttType, SttClass]) (List [StmUnknown "private", StmStatic]) + exampleTokens1 = [ + SemanticTokenAbsolute 2 5 3 SttProperty [StmUnknown "private", StmStatic] + , SemanticTokenAbsolute 2 10 4 SttType [] + , SemanticTokenAbsolute 5 2 7 SttClass [] + ] + exampleTokens2 = [ + SemanticTokenAbsolute 3 5 3 SttProperty [StmUnknown "private", StmStatic] + , SemanticTokenAbsolute 3 10 4 SttType [] + , SemanticTokenAbsolute 6 2 7 SttClass [] + ] + + bigNumber :: Int + bigNumber = 100000 + bigTokens = + unfoldr (\i -> if i == bigNumber then Nothing else Just (SemanticTokenAbsolute i 1 1 SttType [StmUnknown "private", StmStatic], i+1)) 0 + -- Relativized version of bigTokens + bigTokensRel = + unfoldr (\i -> if i == bigNumber then Nothing else Just (SemanticTokenRelative (if i == 0 then 0 else 1) 1 1 SttType [StmUnknown "private", StmStatic], i+1)) 0 + + -- One more order of magnitude makes diffing more-or-less hang - possibly we need a better diffing algorithm, since this is only ~= 200 tokens at 5 ints per token + -- (I checked and it is the diffing that's slow, not turning it into edits) + smallerBigNumber :: Int + smallerBigNumber = 1000 + bigInts :: [Int] + bigInts = + unfoldr (\i -> if i == smallerBigNumber then Nothing else Just (1, i+1)) 0 + bigInts2 :: [Int] + bigInts2 = + unfoldr (\i -> if i == smallerBigNumber then Nothing else Just (if even i then 2 else 1, i+1)) 0 + + describe "relativize/absolutizeTokens" $ do + it "round-trips" $ do + absolutizeTokens (relativizeTokens exampleTokens1) `shouldBe` exampleTokens1 + absolutizeTokens (relativizeTokens exampleTokens2) `shouldBe` exampleTokens2 + it "handles big tokens" $ relativizeTokens bigTokens `shouldBe` bigTokensRel + + describe "encodeTokens" $ do + context "when running the LSP examples" $ do + it "encodes example 1 correctly" $ + let encoded = encodeTokens exampleLegend (relativizeTokens exampleTokens1) + in encoded `shouldBe` Right [{- token 1 -}2,5,3,0,3,{- token 2 -}0,5,4,1,0,{- token 3 -}3,2,7,2,0] + it "encodes example 2 correctly" $ + let encoded = encodeTokens exampleLegend (relativizeTokens exampleTokens2) + in encoded `shouldBe` Right [{- token 1 -}3,5,3,0,3,{- token 2 -}0,5,4,1,0,{- token 3 -}3,2,7,2,0] + it "handles big tokens" $ encodeTokens exampleLegend bigTokensRel `shouldSatisfy` isRight + + describe "computeEdits" $ do + it "handles an edit in the middle" $ + computeEdits @Int [1,2,3] [1,4,5,3] `shouldBe` [Edit 1 1 [4,5]] + it "handles an edit at the end" $ + computeEdits @Int [1,2,3] [1,2,4,5] `shouldBe` [Edit 2 1 [4,5]] + it "handles an edit at the beginning" $ + computeEdits @Int [1,2,3] [4,5,2,3] `shouldBe` [Edit 0 1 [4,5]] + it "handles an ambiguous edit" $ + computeEdits @Int [1,2,3] [1,3,4,3] `shouldBe` [Edit 1 1 [], Edit 3 0 [4,3]] + it "handles a long edit" $ + computeEdits @Int [1,2,3,4,5] [1,7,7,7,7,7,5] `shouldBe` [Edit 1 3 [7,7,7,7,7]] + it "handles multiple edits" $ + computeEdits @Int [1,2,3,4,5] [1,6,3,7,7,5] `shouldBe` [Edit 1 1 [6], Edit 3 1 [7,7]] + it "handles big tokens" $ + -- It's a little hard to specify a useful predicate here, the main point is that it should not take too long + computeEdits @Int bigInts bigInts2 `shouldSatisfy` (not . null) diff --git a/test/ServerCapabilitiesSpec.hs b/test/ServerCapabilitiesSpec.hs --- a/test/ServerCapabilitiesSpec.hs +++ b/test/ServerCapabilitiesSpec.hs @@ -28,6 +28,13 @@ let input = "{\"hoverProvider\": true, \"colorProvider\": {\"id\": \"abc123\", \"documentSelector\": " <> documentFiltersJson <> "}}" Just caps = decode input :: Maybe ServerCapabilities in caps ^. colorProvider `shouldBe` Just (InR $ InR $ DocumentColorRegistrationOptions (Just documentFilters) (Just "abc123") Nothing) + describe "client/registerCapability" $ + it "allows empty registerOptions" $ + let input = "{\"registrations\":[{\"registerOptions\":{},\"method\":\"workspace/didChangeConfiguration\",\"id\":\"4a56f5ca-7188-4f4c-a366-652d6f9d63aa\"}]}" + Just registrationParams = decode input :: Maybe RegistrationParams + in registrationParams ^. registrations `shouldBe` + List [SomeRegistration $ Registration "4a56f5ca-7188-4f4c-a366-652d6f9d63aa" + SWorkspaceDidChangeConfiguration Empty] where documentFilters = List [DocumentFilter (Just "haskell") Nothing Nothing] documentFiltersJson = "[{\"language\": \"haskell\"}]"