lsp 1.2.0.0 → 1.2.0.1
raw patch · 7 files changed
+159/−56 lines, 7 filesdep +exceptionsdep ~basedep ~lsp-typesdep ~stm
Dependencies added: exceptions
Dependency ranges changed: base, lsp-types, stm
Files
- ChangeLog.md +9/−0
- lsp.cabal +8/−13
- src/Language/LSP/Server/Core.hs +38/−35
- src/Language/LSP/Server/Processing.hs +14/−8
- test/MethodSpec.hs +9/−0
- test/SemanticTokensSpec.hs +74/−0
- test/ServerCapabilitiesSpec.hs +7/−0
ChangeLog.md view
@@ -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)
lsp.cabal view
@@ -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
src/Language/LSP/Server/Core.hs view
@@ -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,
src/Language/LSP/Server/Processing.hs view
@@ -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)
test/MethodSpec.hs view
@@ -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]
+ test/SemanticTokensSpec.hs view
@@ -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)
test/ServerCapabilitiesSpec.hs view
@@ -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\"}]"