diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Revision history for lsp-client + +## 0.2.0.0 -- 2023-11-01 + +* Support lsp-types 2.0 +* Move compat functionality to unix-compat >= 0.7.1 + +## 0.1.0.0 -- 2023-06-20 + +* First version. diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for lsp-client - -## 0.1.0.0 -- 2023-06-20 - -* First version. diff --git a/LICENCE b/LICENCE deleted file mode 100644 --- a/LICENCE +++ /dev/null @@ -1,202 +0,0 @@ - - Apache License - Version 2.0, January 2004 - http://www.apache.org/licenses/ - - TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION - - 1. Definitions. - - "License" shall mean the terms and conditions for use, reproduction, - and distribution as defined by Sections 1 through 9 of this document. - - "Licensor" shall mean the copyright owner or entity authorized by - the copyright owner that is granting the License. - - "Legal Entity" shall mean the union of the acting entity and all - other entities that control, are controlled by, or are under common - control with that entity. For the purposes of this definition, - "control" means (i) the power, direct or indirect, to cause the - direction or management of such entity, whether by contract or - otherwise, or (ii) ownership of fifty percent (50%) or more of the - outstanding shares, or (iii) beneficial ownership of such entity. - - "You" (or "Your") shall mean an individual or Legal Entity - exercising permissions granted by this License. - - "Source" form shall mean the preferred form for making modifications, - including but not limited to software source code, documentation - source, and configuration files. - - "Object" form shall mean any form resulting from mechanical - transformation or translation of a Source form, including but - not limited to compiled object code, generated documentation, - and conversions to other media types. - - "Work" shall mean the work of authorship, whether in Source or - Object form, made available under the License, as indicated by a - copyright notice that is included in or attached to the work - (an example is provided in the Appendix below). - - "Derivative Works" shall mean any work, whether in Source or Object - form, that is based on (or derived from) the Work and for which the - editorial revisions, annotations, elaborations, or other modifications - represent, as a whole, an original work of authorship. For the purposes - of this License, Derivative Works shall not include works that remain - separable from, or merely link (or bind by name) to the interfaces of, - the Work and Derivative Works thereof. - - "Contribution" shall mean any work of authorship, including - the original version of the Work and any modifications or additions - to that Work or Derivative Works thereof, that is intentionally - submitted to Licensor for inclusion in the Work by the copyright owner - or by an individual or Legal Entity authorized to submit on behalf of - the copyright owner. For the purposes of this definition, "submitted" - means any form of electronic, verbal, or written communication sent - to the Licensor or its representatives, including but not limited to - communication on electronic mailing lists, source code control systems, - and issue tracking systems that are managed by, or on behalf of, the - Licensor for the purpose of discussing and improving the Work, but - excluding communication that is conspicuously marked or otherwise - designated in writing by the copyright owner as "Not a Contribution." - - "Contributor" shall mean Licensor and any individual or Legal Entity - on behalf of whom a Contribution has been received by Licensor and - subsequently incorporated within the Work. - - 2. Grant of Copyright License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - copyright license to reproduce, prepare Derivative Works of, - publicly display, publicly perform, sublicense, and distribute the - Work and such Derivative Works in Source or Object form. - - 3. Grant of Patent License. Subject to the terms and conditions of - this License, each Contributor hereby grants to You a perpetual, - worldwide, non-exclusive, no-charge, royalty-free, irrevocable - (except as stated in this section) patent license to make, have made, - use, offer to sell, sell, import, and otherwise transfer the Work, - where such license applies only to those patent claims licensable - by such Contributor that are necessarily infringed by their - Contribution(s) alone or by combination of their Contribution(s) - with the Work to which such Contribution(s) was submitted. If You - institute patent litigation against any entity (including a - cross-claim or counterclaim in a lawsuit) alleging that the Work - or a Contribution incorporated within the Work constitutes direct - or contributory patent infringement, then any patent licenses - granted to You under this License for that Work shall terminate - as of the date such litigation is filed. - - 4. Redistribution. You may reproduce and distribute copies of the - Work or Derivative Works thereof in any medium, with or without - modifications, and in Source or Object form, provided that You - meet the following conditions: - - (a) You must give any other recipients of the Work or - Derivative Works a copy of this License; and - - (b) You must cause any modified files to carry prominent notices - stating that You changed the files; and - - (c) You must retain, in the Source form of any Derivative Works - that You distribute, all copyright, patent, trademark, and - attribution notices from the Source form of the Work, - excluding those notices that do not pertain to any part of - the Derivative Works; and - - (d) If the Work includes a "NOTICE" text file as part of its - distribution, then any Derivative Works that You distribute must - include a readable copy of the attribution notices contained - within such NOTICE file, excluding those notices that do not - pertain to any part of the Derivative Works, in at least one - of the following places: within a NOTICE text file distributed - as part of the Derivative Works; within the Source form or - documentation, if provided along with the Derivative Works; or, - within a display generated by the Derivative Works, if and - wherever such third-party notices normally appear. The contents - of the NOTICE file are for informational purposes only and - do not modify the License. You may add Your own attribution - notices within Derivative Works that You distribute, alongside - or as an addendum to the NOTICE text from the Work, provided - that such additional attribution notices cannot be construed - as modifying the License. - - You may add Your own copyright statement to Your modifications and - may provide additional or different license terms and conditions - for use, reproduction, or distribution of Your modifications, or - for any such Derivative Works as a whole, provided Your use, - reproduction, and distribution of the Work otherwise complies with - the conditions stated in this License. - - 5. Submission of Contributions. Unless You explicitly state otherwise, - any Contribution intentionally submitted for inclusion in the Work - by You to the Licensor shall be under the terms and conditions of - this License, without any additional terms or conditions. - Notwithstanding the above, nothing herein shall supersede or modify - the terms of any separate license agreement you may have executed - with Licensor regarding such Contributions. - - 6. Trademarks. This License does not grant permission to use the trade - names, trademarks, service marks, or product names of the Licensor, - except as required for reasonable and customary use in describing the - origin of the Work and reproducing the content of the NOTICE file. - - 7. Disclaimer of Warranty. Unless required by applicable law or - agreed to in writing, Licensor provides the Work (and each - Contributor provides its Contributions) on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or - implied, including, without limitation, any warranties or conditions - of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A - PARTICULAR PURPOSE. You are solely responsible for determining the - appropriateness of using or redistributing the Work and assume any - risks associated with Your exercise of permissions under this License. - - 8. Limitation of Liability. In no event and under no legal theory, - whether in tort (including negligence), contract, or otherwise, - unless required by applicable law (such as deliberate and grossly - negligent acts) or agreed to in writing, shall any Contributor be - liable to You for damages, including any direct, indirect, special, - incidental, or consequential damages of any character arising as a - result of this License or out of the use or inability to use the - Work (including but not limited to damages for loss of goodwill, - work stoppage, computer failure or malfunction, or any and all - other commercial damages or losses), even if such Contributor - has been advised of the possibility of such damages. - - 9. Accepting Warranty or Additional Liability. While redistributing - the Work or Derivative Works thereof, You may choose to offer, - and charge a fee for, acceptance of support, warranty, indemnity, - or other liability obligations and/or rights consistent with this - License. However, in accepting such obligations, You may act only - on Your own behalf and on Your sole responsibility, not on behalf - of any other Contributor, and only if You agree to indemnify, - defend, and hold each Contributor harmless for any liability - incurred by, or claims asserted against, such Contributor by reason - of your accepting any such warranty or additional liability. - - END OF TERMS AND CONDITIONS - - APPENDIX: How to apply the Apache License to your work. - - To apply the Apache License to your work, attach the following - boilerplate notice, with the fields enclosed by brackets "[]" - replaced with your own identifying information. (Don't include - the brackets!) The text should be enclosed in the appropriate - comment syntax for the file format. We also recommend that a - file or class name and description of purpose be included on the - same "printed page" as the copyright notice for easier - identification within third-party archives. - - Copyright [yyyy] [name of copyright owner] - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - http://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. diff --git a/LICENCE.md b/LICENCE.md new file mode 100644 --- /dev/null +++ b/LICENCE.md @@ -0,0 +1,13 @@ +Copyright 2024 ners + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/lsp-client.cabal b/lsp-client.cabal --- a/lsp-client.cabal +++ b/lsp-client.cabal @@ -1,16 +1,17 @@ cabal-version: 3.0 name: lsp-client -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Haskell library for Language Server Protocol clients homepage: https://github.com/ners/lsp-client/blob/master/README.md license: Apache-2.0 -license-file: LICENCE +license-file: LICENCE.md author: ners maintainer: ners@gmx.ch bug-reports: https://github.com/ners/lsp-client/issues category: System build-type: Simple -extra-source-files: ChangeLog.md, README.md +extra-source-files: CHANGELOG.md, README.md +tested-with: GHC == { 9.2, 9.4, 9.6 } source-repository head type: git @@ -44,12 +45,13 @@ TypeFamilies ViewPatterns build-depends: - aeson >= 2.0 && < 3, + aeson >= 2 && < 3, base >= 4.16 && < 5, - bytestring, - lens >= 5.0, - lsp-types >= 1.6.0.0, - unliftio >= 0.2, + bytestring >= 0.9 && < 0.13, + lens >= 5 && < 6, + lsp-types >= 2 && < 3, + unliftio >= 0.2 && < 0.3, + row-types, library import: common @@ -59,25 +61,23 @@ Glob, aeson-pretty, co-log-core, + containers, data-default, dependent-map, directory, + extra, filepath, generic-lens, - hashable, lsp, mtl, stm, text, text-rope, unordered-containers, - if os(windows) - build-depends: Win32 - else - build-depends: unix + unix-compat >= 0.7.1 && < 0.8, exposed-modules: + Control.Concurrent.STM.TVar.Extra, Language.LSP.Client, - Language.LSP.Client.Compat, Language.LSP.Client.Decoding, Language.LSP.Client.Encoding, Language.LSP.Client.Exceptions, @@ -96,4 +96,4 @@ lsp-client, process, other-modules: - Language.LSP.ClientSpec + Language.LSP.ClientSpec, diff --git a/src/Control/Concurrent/STM/TVar/Extra.hs b/src/Control/Concurrent/STM/TVar/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Control/Concurrent/STM/TVar/Extra.hs @@ -0,0 +1,16 @@ +module Control.Concurrent.STM.TVar.Extra where + +import Control.Concurrent.STM +import Prelude + +overTVar :: (a -> a) -> TVar a -> STM a +overTVar f var = stateTVar var (\x -> (f x, f x)) + +overTVarIO :: (a -> a) -> TVar a -> IO a +overTVarIO = (atomically .) . overTVar + +modifyTVarIO :: TVar a -> (a -> a) -> IO () +modifyTVarIO = (atomically .) . modifyTVar + +writeTVarIO :: TVar a -> a -> IO () +writeTVarIO = (atomically .) . writeTVar diff --git a/src/Language/LSP/Client.hs b/src/Language/LSP/Client.hs --- a/src/Language/LSP/Client.hs +++ b/src/Language/LSP/Client.hs @@ -14,10 +14,9 @@ import Language.LSP.Client.Decoding import Language.LSP.Client.Encoding (encode) import Language.LSP.Client.Session -import Language.LSP.Types (From, Method, MethodType, SMethod (..)) -import Language.LSP.Types qualified as LSP -import Language.LSP.VFS (initVFS) -import System.IO (Handle, stdin, stdout) +import Language.LSP.Protocol.Message qualified as LSP +import Language.LSP.VFS (emptyVFS) +import System.IO (Handle) import UnliftIO (concurrently_, race) import Prelude @@ -32,8 +31,8 @@ -> Session a -- ^ Session actions -> IO a -runSessionWithHandles input output action = initVFS $ \vfs -> do - initialState <- defaultSessionState vfs +runSessionWithHandles input output action = do + initialState <- defaultSessionState emptyVFS flip runReaderT initialState $ do actionResult <- race action $ do let send = do @@ -43,12 +42,14 @@ serverBytes <- liftIO $ getNextMessage input (serverMessage, requestCallback) <- asks pendingRequests - >>= liftIO . atomically . flip stateTVar (decodeFromServerMsg serverBytes) + >>= liftIO + . atomically + . flip stateTVar (decodeFromServerMsg serverBytes) handleServerMessage serverMessage liftIO requestCallback case serverMessage of - LSP.FromServerMess smethod msg -> case methodType smethod of - Notification -> do + LSP.FromServerMess smethod msg -> case LSP.splitServerMethod smethod of + LSP.IsServerNot -> do handlers :: NotificationMap <- asks notificationHandlers >>= liftIO . readTVarIO let NotificationCallback cb = DMap.findWithDefault (NotificationCallback (const $ pure ())) smethod handlers liftIO $ cb msg @@ -56,73 +57,3 @@ _ -> pure () concurrently_ (forever send) (forever receive) pure $ fromLeft (error "runSessionWithHandle: send/receive thread should not exit") actionResult - -data SMethodType (t :: MethodType) where - Notification :: SMethodType 'LSP.Notification - Request :: SMethodType 'LSP.Request - -methodType :: forall (f :: From) (t :: MethodType) (m :: Method f t). SMethod m -> SMethodType t -methodType SInitialize = Request -methodType SInitialized = Notification -methodType SShutdown = Request -methodType SExit = Notification -methodType SWorkspaceDidChangeWorkspaceFolders = Notification -methodType SWorkspaceDidChangeConfiguration = Notification -methodType SWorkspaceDidChangeWatchedFiles = Notification -methodType SWorkspaceSymbol = Request -methodType SWorkspaceExecuteCommand = Request -methodType STextDocumentDidOpen = Notification -methodType STextDocumentDidChange = Notification -methodType STextDocumentWillSave = Notification -methodType STextDocumentWillSaveWaitUntil = Request -methodType STextDocumentDidSave = Notification -methodType STextDocumentDidClose = Notification -methodType STextDocumentCompletion = Request -methodType SCompletionItemResolve = Request -methodType STextDocumentHover = Request -methodType STextDocumentSignatureHelp = Request -methodType STextDocumentDeclaration = Request -methodType STextDocumentDefinition = Request -methodType STextDocumentTypeDefinition = Request -methodType STextDocumentImplementation = Request -methodType STextDocumentReferences = Request -methodType STextDocumentDocumentHighlight = Request -methodType STextDocumentDocumentSymbol = Request -methodType STextDocumentCodeAction = Request -methodType STextDocumentCodeLens = Request -methodType SCodeLensResolve = Request -methodType STextDocumentDocumentLink = Request -methodType SDocumentLinkResolve = Request -methodType STextDocumentDocumentColor = Request -methodType STextDocumentColorPresentation = Request -methodType STextDocumentFormatting = Request -methodType STextDocumentRangeFormatting = Request -methodType STextDocumentOnTypeFormatting = Request -methodType STextDocumentRename = Request -methodType STextDocumentPrepareRename = Request -methodType STextDocumentFoldingRange = Request -methodType STextDocumentSelectionRange = Request -methodType STextDocumentPrepareCallHierarchy = Request -methodType SCallHierarchyIncomingCalls = Request -methodType SCallHierarchyOutgoingCalls = Request -methodType STextDocumentSemanticTokens = Request -methodType STextDocumentSemanticTokensFull = Request -methodType STextDocumentSemanticTokensFullDelta = Request -methodType STextDocumentSemanticTokensRange = Request -methodType SWindowShowMessage = Notification -methodType SWindowShowMessageRequest = Request -methodType SWindowShowDocument = Request -methodType SWindowLogMessage = Notification -methodType SWindowWorkDoneProgressCancel = Notification -methodType SWindowWorkDoneProgressCreate = Request -methodType SProgress = Notification -methodType STelemetryEvent = Notification -methodType SClientRegisterCapability = Request -methodType SClientUnregisterCapability = Request -methodType SWorkspaceWorkspaceFolders = Request -methodType SWorkspaceConfiguration = Request -methodType SWorkspaceApplyEdit = Request -methodType SWorkspaceSemanticTokensRefresh = Request -methodType STextDocumentPublishDiagnostics = Notification -methodType SCancelRequest = Notification -methodType (SCustomMethod _) = undefined diff --git a/src/Language/LSP/Client/Compat.hs b/src/Language/LSP/Client/Compat.hs deleted file mode 100644 --- a/src/Language/LSP/Client/Compat.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Language.LSP.Client.Compat where - -import Language.LSP.Types -import Prelude - -#ifdef mingw32_HOST_OS -import System.Win32.Process qualified -#else -import System.Posix.Process qualified -#endif - -getCurrentProcessID :: IO Int -#ifdef mingw32_HOST_OS -getCurrentProcessID = fromIntegral <$> System.Win32.Process.getCurrentProcessID -#else -getCurrentProcessID = fromIntegral <$> System.Posix.Process.getProcessID -#endif - -lspClientInfo :: ClientInfo -lspClientInfo = ClientInfo "lsp-client" (Just CURRENT_PACKAGE_VERSION) diff --git a/src/Language/LSP/Client/Decoding.hs b/src/Language/LSP/Client/Decoding.hs --- a/src/Language/LSP/Client/Decoding.hs +++ b/src/Language/LSP/Client/Decoding.hs @@ -19,7 +19,7 @@ import Data.IxMap qualified as IxMap import Data.Maybe (fromJust, fromMaybe) import Language.LSP.Client.Exceptions -import Language.LSP.Types +import Language.LSP.Protocol.Message (FromServerMessage, FromServerMessage' (FromServerMess, FromServerRsp), LspId, MessageDirection (..), MessageKind (..), Method, SClientMethod, SMethod, TNotificationMessage, TResponseMessage (..), parseServerMessage) import System.IO (Handle, hGetLine) import System.IO.Error (isEOFError) import Prelude hiding (id) @@ -50,9 +50,9 @@ emptyRequestMap :: RequestMap emptyRequestMap = IxMap.emptyIxMap -data RequestCallback (m :: Method 'FromClient 'Request) = RequestCallback - { requestCallback :: ResponseMessage m -> IO () - , requestMethod :: SMethod m +data RequestCallback (m :: Method 'ClientToServer 'Request) = RequestCallback + { requestCallback :: TResponseMessage m -> IO () + , requestMethod :: SClientMethod m } type NotificationMap = DMap SMethod NotificationCallback @@ -60,8 +60,8 @@ emptyNotificationMap :: NotificationMap emptyNotificationMap = mempty -newtype NotificationCallback (m :: Method 'FromServer 'Notification) = NotificationCallback - { notificationCallback :: Message m -> IO () +newtype NotificationCallback (m :: Method 'ServerToClient 'Notification) = NotificationCallback + { notificationCallback :: TNotificationMessage m -> IO () } instance Semigroup (NotificationCallback m) where @@ -76,7 +76,7 @@ appendNotificationCallback :: SMethod m -> NotificationCallback m -> NotificationMap -> NotificationMap appendNotificationCallback = DMap.insertWith' (<>) -removeNotificationCallback :: SMethod (m :: Method 'FromServer 'Notification) -> NotificationMap -> NotificationMap +removeNotificationCallback :: SMethod (m :: Method 'ServerToClient 'Notification) -> NotificationMap -> NotificationMap removeNotificationCallback = DMap.delete decodeFromServerMsg :: LazyByteString -> RequestMap -> ((FromServerMessage, IO ()), RequestMap) @@ -87,5 +87,6 @@ let (maybeCallback, newMap) = IxMap.pickFromIxMap lid reqMap in maybeCallback <&> \c -> (c.requestMethod, Pair c (Const newMap)) unP (Success (FromServerMess m msg)) = ((FromServerMess m msg, pure ()), reqMap) - unP (Success (FromServerRsp (Pair c (Const newMap)) msg)) = ((FromServerRsp c.requestMethod msg, c.requestCallback msg), newMap) + unP (Success (FromServerRsp (Pair c (Const newMap)) msg)) = + ((FromServerRsp c.requestMethod msg, c.requestCallback msg), newMap) unP (Error e) = error $ "Error decoding " <> show obj <> " :" <> e diff --git a/src/Language/LSP/Client/Encoding.hs b/src/Language/LSP/Client/Encoding.hs --- a/src/Language/LSP/Client/Encoding.hs +++ b/src/Language/LSP/Client/Encoding.hs @@ -16,5 +16,5 @@ , content ] -encode :: ToJSON a => a -> LazyByteString +encode :: (ToJSON a) => a -> LazyByteString encode = addHeader . Aeson.encode diff --git a/src/Language/LSP/Client/Exceptions.hs b/src/Language/LSP/Client/Exceptions.hs --- a/src/Language/LSP/Client/Exceptions.hs +++ b/src/Language/LSP/Client/Exceptions.hs @@ -7,7 +7,7 @@ import Data.Algorithm.DiffOutput (ppDiff) import Data.ByteString.Lazy.Char8 qualified as LazyByteString import Data.List (nub) -import Language.LSP.Types +import Language.LSP.Protocol.Message ( FromServerMessage , ResponseError , SomeLspId diff --git a/src/Language/LSP/Client/Session.hs b/src/Language/LSP/Client/Session.hs --- a/src/Language/LSP/Client/Session.hs +++ b/src/Language/LSP/Client/Session.hs @@ -1,16 +1,16 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-orphans #-} - -{-| --} +{-# LANGUAGE CPP #-} module Language.LSP.Client.Session where import Colog.Core (LogAction (..), Severity (..), WithSeverity (..)) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM +import Control.Concurrent.STM.TVar.Extra import Control.Exception (throw) import Control.Lens hiding (Empty, List) +import Control.Lens.Extras (is) import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Reader (ReaderT, asks) @@ -24,21 +24,22 @@ import Data.HashMap.Strict qualified as HashMap import Data.HashSet (HashSet) import Data.HashSet qualified as HashSet -import Data.Hashable (Hashable) -import Data.List (groupBy, sortBy) +import Data.List (sortBy) +import Data.List.Extra (groupOn) +import Data.Map.Strict qualified as Map import Data.Maybe (fromJust, fromMaybe, mapMaybe) +import Data.Row import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text import Data.Text.Utf16.Rope (Rope) -import GHC.Generics (Generic) -import Language.LSP.Client.Compat (getCurrentProcessID, lspClientInfo) import Language.LSP.Client.Decoding import Language.LSP.Client.Exceptions (SessionException (UnexpectedResponseError)) -import Language.LSP.Types -import Language.LSP.Types.Capabilities (ClientCapabilities, fullCaps) -import Language.LSP.Types.Lens hiding (applyEdit, capabilities, executeCommand, id, message, rename, to) -import Language.LSP.Types.Lens qualified as LSP +import Language.LSP.Protocol.Capabilities (fullCaps) +import Language.LSP.Protocol.Lens hiding (error, to) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import System.PosixCompat.Process (getProcessID) import Language.LSP.VFS ( VFS , VfsLog @@ -54,11 +55,8 @@ import System.Directory (canonicalizePath) import System.FilePath (isAbsolute, ()) import System.FilePath.Glob qualified as Glob -import Prelude - -deriving stock instance Generic ProgressToken - -deriving anyclass instance Hashable ProgressToken +import Prelude hiding (id) +import Prelude qualified data SessionState = SessionState { initialized :: TMVar InitializeResult @@ -100,9 +98,10 @@ , .. } --- | A session representing one instance of launching and connecting to a server. --- It is essentially an STM-backed `StateT`: despite it being `ReaderT`, it can still --- mutate `TVar` values. +{- | A session representing one instance of launching and connecting to a server. +It is essentially an STM-backed `StateT`: despite it being `ReaderT`, it can still +mutate `TVar` values. +-} type Session = ReaderT SessionState IO documentChangeUri :: DocumentChange -> Uri @@ -111,67 +110,73 @@ documentChangeUri (InR (InR (InL x))) = x ^. oldUri documentChangeUri (InR (InR (InR x))) = x ^. uri --- | Fires whenever the client receives a message from the server. Updates the session state as needed. --- Note that this does not provide any business logic beyond updating the session state; you most likely --- want to use `sendRequest` and `receiveNotification` to register callbacks for specific messages. -handleServerMessage :: FromServerMessage -> Session () - -handleServerMessage (FromServerMess SProgress req) = do - let update = asks progressTokens >>= liftIO . flip modifyTVarIO (HashSet.insert $ req ^. params . token) - case req ^. params . value of - Begin{} -> update - End{} -> update - Report{} -> pure () +-- eitherOf :: APrism' s a -> (a -> b) -> (s -> b) -> s -> b +-- eitherOf p a b = either b a . matching p +-- +-- anyOf :: [APrism' s a] -> (a -> b) -> b -> s -> b +-- anyOf [] _ b = const b +-- anyOf (p : prisms) a b = eitherOf p a $ anyOf prisms a b -handleServerMessage (FromServerMess SClientRegisterCapability req) = do - let List newRegs = req ^. params . registrations <&> \sr@(SomeRegistration r) -> (r ^. LSP.id, sr) +{- | Fires whenever the client receives a message from the server. Updates the session state as needed. +Note that this does not provide any business logic beyond updating the session state; you most likely +want to use `sendRequest` and `receiveNotification` to register callbacks for specific messages. +-} +handleServerMessage :: FromServerMessage -> Session () +handleServerMessage (FromServerMess SMethod_Progress req) = + when (anyOf folded ($ req ^. params . value) [is _workDoneProgressBegin, is _workDoneProgressEnd]) + $ asks progressTokens + >>= liftIO + . flip modifyTVarIO (HashSet.insert $ req ^. params . token) +handleServerMessage (FromServerMess SMethod_ClientRegisterCapability req) = asks serverCapabilities >>= liftIO . flip modifyTVarIO (HashMap.union (HashMap.fromList newRegs)) - -handleServerMessage (FromServerMess SClientUnregisterCapability req) = do - let List unRegs = req ^. params . unregisterations <&> (^. LSP.id) + where + regs = req ^.. params . registrations . traversed . to toSomeRegistration . _Just + newRegs = (\sr@(SomeRegistration r) -> (r ^. id, sr)) <$> regs +handleServerMessage (FromServerMess SMethod_ClientUnregisterCapability req) = asks serverCapabilities >>= liftIO . flip modifyTVarIO (flip (foldr' HashMap.delete) unRegs) - -handleServerMessage (FromServerMess SWorkspaceApplyEdit r) = do + where + unRegs = (^. id) <$> req ^. params . unregisterations +handleServerMessage (FromServerMess SMethod_WorkspaceApplyEdit r) = do -- First, prefer the versioned documentChanges field allChangeParams <- case r ^. params . edit . documentChanges of - Just (List cs) -> do + Just cs -> do mapM_ (checkIfNeedsOpened . documentChangeUri) cs -- replace the user provided version numbers with the VFS ones + 1 -- (technically we should check that the user versions match the VFS ones) - cs' <- traverseOf (traverse . _InL . textDocument) bumpNewestVersion cs + cs' <- traverseOf (traverse . _L . textDocument) bumpNewestVersion cs return $ mapMaybe getParamsFromDocumentChange cs' -- Then fall back to the changes field Nothing -> case r ^. params . edit . changes of Just cs -> do - mapM_ checkIfNeedsOpened (HashMap.keys cs) - concat <$> mapM (uncurry getChangeParams) (HashMap.toList cs) + mapM_ checkIfNeedsOpened (Map.keys cs) + concat <$> mapM (uncurry getChangeParams) (Map.toList cs) Nothing -> error "WorkspaceEdit contains neither documentChanges nor changes!" asks vfs >>= liftIO . flip modifyTVarIO (execState $ changeFromServerVFS logger r) - let groupedParams = groupBy (\a b -> a ^. textDocument == b ^. textDocument) allChangeParams + let groupedParams = groupOn (view textDocument) allChangeParams mergedParams = mergeParams <$> groupedParams - forM_ mergedParams (sendNotification STextDocumentDidChange) + forM_ mergedParams $ sendNotification SMethod_TextDocumentDidChange -- Update VFS to new document versions let sortedVersions = sortBy (compare `on` (^. textDocument . version)) <$> groupedParams - latestVersions = (^. textDocument) . last <$> sortedVersions + latestVersions = view textDocument . last <$> sortedVersions forM_ latestVersions $ \(VersionedTextDocumentIdentifier uri v) -> asks vfs >>= liftIO - . flip - modifyTVarIO - ( \vfs -> do - let update (VirtualFile oldV file_ver t) = VirtualFile (fromMaybe oldV v) (file_ver + 1) t - in vfs & vfsMap . ix (toNormalizedUri uri) %~ update - ) + . flip + modifyTVarIO + ( \vfs -> do + let update (VirtualFile _ file_ver t) = VirtualFile v (file_ver + 1) t + in vfs & vfsMap . ix (toNormalizedUri uri) %~ update + ) sendResponse r $ Right - ApplyWorkspaceEditResponseBody + ApplyWorkspaceEditResult { _applied = True , _failureReason = Nothing , _failedChange = Nothing @@ -186,7 +191,7 @@ unless isOpen $ do contents <- maybe (pure "") (liftIO . Text.readFile) (uriToFilePath uri) sendNotification - STextDocumentDidOpen + SMethod_TextDocumentDidOpen DidOpenTextDocumentParams { _textDocument = TextDocumentItem @@ -197,19 +202,23 @@ } } - getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams - getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = do - DidChangeTextDocumentParams docId (List $ editToChangeEvent <$> edits) + getParamsFromTextDocumentEdit :: TextDocumentEdit -> Maybe DidChangeTextDocumentParams + getParamsFromTextDocumentEdit (TextDocumentEdit docId edits) = do + DidChangeTextDocumentParams <$> docId ^? _versionedTextDocumentIdentifier <*> pure (editToChangeEvent <$> edits) editToChangeEvent :: TextEdit |? AnnotatedTextEdit -> TextDocumentContentChangeEvent - editToChangeEvent (InR e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) - editToChangeEvent (InL e) = TextDocumentContentChangeEvent (Just $ e ^. range) Nothing (e ^. newText) + editToChangeEvent (InR e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. range) .+ #rangeLength .== Nothing .+ #text .== (e ^. newText) + editToChangeEvent (InL e) = TextDocumentContentChangeEvent $ InL $ #range .== (e ^. range) .+ #rangeLength .== Nothing .+ #text .== (e ^. newText) getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams - getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit + getParamsFromDocumentChange (InL textDocumentEdit) = getParamsFromTextDocumentEdit textDocumentEdit getParamsFromDocumentChange _ = Nothing - bumpNewestVersion (VersionedTextDocumentIdentifier uri _) = head <$> textDocumentVersions uri + bumpNewestVersion :: OptionalVersionedTextDocumentIdentifier -> Session OptionalVersionedTextDocumentIdentifier + bumpNewestVersion (OptionalVersionedTextDocumentIdentifier uri (InL _)) = do + nextVersion <- head <$> textDocumentVersions uri + pure $ OptionalVersionedTextDocumentIdentifier uri $ InL nextVersion._version + bumpNewestVersion i = pure i -- For a uri returns an infinite list of versions [n,n+1,n+2,...] -- where n is the current version @@ -217,69 +226,57 @@ textDocumentVersions uri = do vfs <- asks vfs >>= liftIO . readTVarIO let curVer = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . lsp_version - pure $ VersionedTextDocumentIdentifier uri . Just <$> [curVer + 1 ..] + pure $ VersionedTextDocumentIdentifier uri <$> [curVer + 1 ..] textDocumentEdits uri edits = do vers <- textDocumentVersions uri - pure $ zipWith (\v e -> TextDocumentEdit v (List [InL e])) vers edits + pure $ zipWith (\v e -> TextDocumentEdit (review _versionedTextDocumentIdentifier v) [InL e]) vers edits - getChangeParams uri (List edits) = fmap getParamsFromTextDocumentEdit <$> textDocumentEdits uri (reverse edits) + getChangeParams uri edits = do + edits <- textDocumentEdits uri (reverse edits) + pure $ mapMaybe getParamsFromTextDocumentEdit edits mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams mergeParams params = let events = concat $ toList $ toList . (^. contentChanges) <$> params - in DidChangeTextDocumentParams (head params ^. textDocument) (List events) - -handleServerMessage (FromServerMess SWindowWorkDoneProgressCreate req) = sendResponse req $ Right Empty - + in DidChangeTextDocumentParams (head params ^. textDocument) events +handleServerMessage (FromServerMess SMethod_WindowWorkDoneProgressCreate req) = sendResponse req $ Right Null handleServerMessage _ = pure () -overTVar :: (a -> a) -> TVar a -> STM a -overTVar f var = stateTVar var (\x -> (f x, f x)) - -overTVarIO :: (a -> a) -> TVar a -> IO a -overTVarIO = (atomically .) . overTVar - -modifyTVarIO :: TVar a -> (a -> a) -> IO () -modifyTVarIO = (atomically .) . modifyTVar - -writeTVarIO :: TVar a -> a -> IO () -writeTVarIO = (atomically .) . writeTVar - --- | Sends a request to the server, with a callback that fires when the response arrives. --- Multiple requests can be waiting at the same time. +{- | Sends a request to the server, with a callback that fires when the response arrives. +Multiple requests can be waiting at the same time. +-} sendRequest - :: forall (m :: Method 'FromClient 'Request) - . Message m ~ RequestMessage m + :: forall (m :: Method 'ClientToServer 'Request) + . (TMessage m ~ TRequestMessage m) => SMethod m -> MessageParams m - -> (ResponseMessage m -> IO ()) + -> (TResponseMessage m -> IO ()) -> Session (LspId m) sendRequest requestMethod params requestCallback = do reqId <- asks lastRequestId >>= liftIO . overTVarIO (+ 1) <&> IdInt asks pendingRequests >>= liftIO . flip modifyTVarIO (updateRequestMap reqId RequestCallback{..}) - sendMessage $ fromClientReq $ RequestMessage "2.0" reqId requestMethod params + sendMessage $ fromClientReq $ TRequestMessage "2.0" reqId requestMethod params pure reqId --- | Send a response to the server. This is used internally to acknowledge server requests. --- Users of this library cannot register callbacks to server requests, so this function is probably of no use to them. +{- | Send a response to the server. This is used internally to acknowledge server requests. +Users of this library cannot register callbacks to server requests, so this function is probably of no use to them. +-} sendResponse - :: forall (m :: Method 'FromServer 'Request) - . RequestMessage m - -> Either ResponseError (ResponseResult m) + :: forall (m :: Method 'ServerToClient 'Request) + . TRequestMessage m + -> Either ResponseError (MessageResult m) -> Session () -sendResponse req = - sendMessage - . FromClientRsp (req ^. LSP.method) - . ResponseMessage (req ^. jsonrpc) (Just $ req ^. LSP.id) +sendResponse req res = do + sendMessage $ FromClientRsp req._method $ TResponseMessage req._jsonrpc (Just req._id) res -- | Sends a request to the server and synchronously waits for its response. request - :: forall (m :: Method 'FromClient 'Request) - . Message m ~ RequestMessage m + :: forall (m :: Method 'ClientToServer 'Request) + . (TMessage m ~ TRequestMessage m) => SMethod m -> MessageParams m - -> Session (ResponseMessage m) + -> Session (TResponseMessage m) request method params = do done <- liftIO newEmptyMVar void $ sendRequest method params $ putMVar done @@ -288,83 +285,91 @@ {- | Checks the response for errors and throws an exception if needed. Returns the result if successful. -} -getResponseResult :: ResponseMessage m -> ResponseResult m -getResponseResult response = either err id $ response ^. result +getResponseResult :: TResponseMessage m -> MessageResult m +getResponseResult response = either err Prelude.id $ response ^. result where - lid = SomeLspId $ fromJust $ response ^. LSP.id + lid = SomeLspId $ fromJust response._id err = throw . UnexpectedResponseError lid -- | Sends a notification to the server. Updates the VFS if the notification is a document update. sendNotification - :: forall (m :: Method 'FromClient 'Notification) - . Message m ~ NotificationMessage m + :: forall (m :: Method 'ClientToServer 'Notification) + . (TMessage m ~ TNotificationMessage m) => SMethod m -> MessageParams m -> Session () sendNotification m params = do - let n = NotificationMessage "2.0" m params + let n = TNotificationMessage "2.0" m params vfs <- asks vfs case m of - STextDocumentDidOpen -> liftIO $ modifyTVarIO vfs (execState $ openVFS mempty n) - STextDocumentDidClose -> liftIO $ modifyTVarIO vfs (execState $ closeVFS mempty n) - STextDocumentDidChange -> liftIO $ modifyTVarIO vfs (execState $ changeFromClientVFS mempty n) + SMethod_TextDocumentDidOpen -> liftIO $ modifyTVarIO vfs (execState $ openVFS mempty n) + SMethod_TextDocumentDidClose -> liftIO $ modifyTVarIO vfs (execState $ closeVFS mempty n) + SMethod_TextDocumentDidChange -> liftIO $ modifyTVarIO vfs (execState $ changeFromClientVFS mempty n) _ -> pure () sendMessage $ fromClientNot n --- | Registers a callback for notifications received from the server. --- If multiple callbacks are registered for the same notification method, they will all be called. +{- | Registers a callback for notifications received from the server. +If multiple callbacks are registered for the same notification method, they will all be called. +-} receiveNotification - :: forall (m :: Method 'FromServer 'Notification) - . SMethod m - -> (Message m -> IO ()) + :: forall (m :: Method 'ServerToClient 'Notification) + . (TMessage m ~ TNotificationMessage m) + => SMethod m + -> (TMessage m -> IO ()) -> Session () receiveNotification method notificationCallback = asks notificationHandlers >>= liftIO - . flip - modifyTVarIO - ( appendNotificationCallback method NotificationCallback{..} - ) + . flip + modifyTVarIO + ( appendNotificationCallback method NotificationCallback{..} + ) --- | Clears the registered callback for the given notification method, if any. --- If multiple callbacks have been registered, this clears /all/ of them. +{- | Clears the registered callback for the given notification method, if any. +If multiple callbacks have been registered, this clears /all/ of them. +-} clearNotificationCallback - :: forall (m :: Method 'FromServer 'Notification) + :: forall (m :: Method 'ServerToClient 'Notification) . SMethod m -> Session () clearNotificationCallback method = asks notificationHandlers >>= liftIO - . flip - modifyTVarIO - ( removeNotificationCallback method - ) + . flip + modifyTVarIO + ( removeNotificationCallback method + ) -- | Queues a message to be sent to the server at the client's earliest convenience. sendMessage :: FromClientMessage -> Session () sendMessage msg = asks outgoing >>= liftIO . atomically . (`writeTQueue` msg) --- | Performs the initialisation handshake and synchronously waits for its completion. --- When the function completes, the session is initialised. +lspClientInfo :: Rec ("name" .== Text .+ "version" .== Maybe Text) +lspClientInfo = #name .== "lsp-client" .+ #version .== Just CURRENT_PACKAGE_VERSION + +{- | Performs the initialisation handshake and synchronously waits for its completion. +When the function completes, the session is initialised. +-} initialize :: Session () initialize = do - pid <- liftIO getCurrentProcessID + pid <- liftIO getProcessID response <- request - SInitialize + SMethod_Initialize InitializeParams { _workDoneToken = Nothing - , _processId = Just $ fromIntegral pid + , _processId = InL $ fromIntegral pid , _clientInfo = Just lspClientInfo + , _locale = Nothing , _rootPath = Nothing - , _rootUri = Nothing + , _rootUri = InR Null , _initializationOptions = Nothing , _capabilities = fullCaps - , _trace = Just TraceOff + , _trace = Just TraceValues_Off , _workspaceFolders = Nothing } asks initialized >>= liftIO . atomically . flip putTMVar (getResponseResult response) - sendNotification SInitialized $ Just InitializedParams + sendNotification SMethod_Initialized InitializedParams {- | /Creates/ a new text document. This is different from 'openDoc' as it sends a @workspace/didChangeWatchedFiles@ notification letting the server @@ -388,20 +393,21 @@ clientCaps <- asks clientCapabilities rootDir <- asks rootDir absFile <- liftIO $ canonicalizePath (rootDir file) - let pred :: SomeRegistration -> [Registration 'WorkspaceDidChangeWatchedFiles] - pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r] + let pred :: SomeRegistration -> [TRegistration 'Method_WorkspaceDidChangeWatchedFiles] + pred (SomeRegistration r@TRegistration{_method = SMethod_WorkspaceDidChangeWatchedFiles}) = [r] pred _ = mempty - regs :: [Registration 'WorkspaceDidChangeWatchedFiles] + regs :: [TRegistration 'Method_WorkspaceDidChangeWatchedFiles] regs = concatMap pred $ HashMap.elems serverCaps watchHits :: FileSystemWatcher -> Bool - watchHits (FileSystemWatcher pattern kind) = - -- If WatchKind is excluded, defaults to all true as per spec - fileMatches (Text.unpack pattern) && maybe True (view watchCreate) kind + watchHits (FileSystemWatcher (GlobPattern (InL (Pattern pattern))) kind) = + fileMatches (Text.unpack pattern) && maybe True containsCreate kind + watchHits _ = False + fileMatches :: String -> Bool fileMatches pattern = Glob.match (Glob.compile pattern) (if isAbsolute pattern then absFile else file) - regHits :: Registration 'WorkspaceDidChangeWatchedFiles -> Bool - regHits reg = any watchHits $ reg ^. registerOptions . watchers + regHits :: TRegistration 'Method_WorkspaceDidChangeWatchedFiles -> Bool + regHits reg = any watchHits $ reg ^. registerOptions . _Just . watchers clientCapsSupports = clientCaps @@ -411,13 +417,13 @@ . _Just . dynamicRegistration . _Just - == Just True + == Just True shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs - when shouldSend $ - sendNotification SWorkspaceDidChangeWatchedFiles $ - DidChangeWatchedFilesParams $ - List [FileEvent (filePathToUri (rootDir file)) FcCreated] + when shouldSend + $ sendNotification SMethod_WorkspaceDidChangeWatchedFiles + $ DidChangeWatchedFilesParams + [FileEvent (filePathToUri $ rootDir file) FileChangeType_Created] openDoc' file language contents {- | Opens a text document that /exists on disk/, and sends a @@ -439,21 +445,21 @@ let fp = rootDir file uri = filePathToUri fp item = TextDocumentItem uri language 0 contents - sendNotification STextDocumentDidOpen (DidOpenTextDocumentParams item) + sendNotification SMethod_TextDocumentDidOpen (DidOpenTextDocumentParams item) pure $ TextDocumentIdentifier uri -- | Closes a text document and sends a @textDocument/didClose@ notification to the server. closeDoc :: TextDocumentIdentifier -> Session () closeDoc docId = do let params = DidCloseTextDocumentParams (TextDocumentIdentifier (docId ^. uri)) - sendNotification STextDocumentDidClose params + sendNotification SMethod_TextDocumentDidClose params -- | Changes a text document and sends a @textDocument/didChange@ notification to the server. changeDoc :: TextDocumentIdentifier -> [TextDocumentContentChangeEvent] -> Session () changeDoc docId changes = do verDoc <- getVersionedDoc docId - let params = DidChangeTextDocumentParams (verDoc & version . non 0 +~ 1) (List changes) - sendNotification STextDocumentDidChange params + let params = DidChangeTextDocumentParams (verDoc & version +~ 1) changes + sendNotification SMethod_TextDocumentDidChange params -- | Gets the Uri for the file relative to the session's root directory. getDocUri :: FilePath -> Session Uri @@ -472,5 +478,5 @@ getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier getVersionedDoc (TextDocumentIdentifier uri) = do vfs <- asks vfs >>= liftIO . readTVarIO - let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion + let ver = fromMaybe 0 $ vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion pure $ VersionedTextDocumentIdentifier uri ver diff --git a/test/Language/LSP/ClientSpec.hs b/test/Language/LSP/ClientSpec.hs --- a/test/Language/LSP/ClientSpec.hs +++ b/test/Language/LSP/ClientSpec.hs @@ -1,6 +1,7 @@ module Language.LSP.ClientSpec where import Control.Arrow ((>>>)) +import Control.Concurrent.STM.TVar.Extra (writeTVarIO) import Control.Exception import Control.Lens ((^.)) import Control.Monad @@ -13,15 +14,17 @@ import Data.ByteString.Lazy qualified as LazyByteString import Data.Coerce (coerce) import Data.Maybe (fromJust) +import Data.Row +import Data.String (IsString) import Data.Tuple.Extra (thd3) import Language.LSP.Client import Language.LSP.Client.Decoding (getNextMessage) import Language.LSP.Client.Encoding (encode) import Language.LSP.Client.Session import Language.LSP.Client.Session qualified as LSP -import Language.LSP.Types -import Language.LSP.Types qualified as LSP -import Language.LSP.Types.Lens qualified as LSP +import Language.LSP.Protocol.Lens qualified as LSP +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types import System.IO import System.Process (createPipe) import Test.Hspec hiding (shouldReturn) @@ -35,7 +38,7 @@ shouldReturn :: (MonadIO m, Show a, Eq a) => m a -> a -> m () shouldReturn a expected = a >>= liftIO . flip Hspec.shouldBe expected -withTimeout :: forall m a. MonadUnliftIO m => Int -> m a -> m a +withTimeout :: forall m a. (MonadUnliftIO m) => Int -> m a -> m a withTimeout delay a = fromEither =<< race timeout a where timeout = do @@ -52,10 +55,12 @@ } , _severity = Nothing , _code = Just $ InL $ fromIntegral i + , _codeDescription = Nothing , _source = Nothing , _message = "" , _tags = Nothing , _relatedInformation = Nothing + , _data_ = Nothing } -- | LSP server that does not read input, and sends dummy diagnostics once per second @@ -70,13 +75,13 @@ threadId <- forkIO $ forM_ [1 ..] $ \i -> do threadDelay 1_000 let message = - NotificationMessage + TNotificationMessage "2.0" - STextDocumentPublishDiagnostics + SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams { _uri = Uri "" , _version = Nothing - , _diagnostics = List [diagnostic i] + , _diagnostics = [diagnostic i] } LazyByteString.hPut outWrite $ encode message pure (inWrite, outRead, threadId) @@ -95,8 +100,8 @@ bytes <- liftIO $ getNextMessage inRead let obj = fromJust $ Aeson.decode bytes idMaybe = parseMaybe (.: "id") obj - message :: ResponseMessage 'Shutdown - message = ResponseMessage "2.0" idMaybe (Right Empty) + message :: TResponseMessage 'Method_Shutdown + message = TResponseMessage "2.0" idMaybe (Right Null) forkIO $ do threadDelay 1_000 takeMVar lock @@ -139,7 +144,7 @@ diagnostics <- newTVarIO @_ @[Diagnostic] [] let getDiagnostics = readTVarIO diagnostics setDiagnostics = writeTVarIO diagnostics - receiveNotification LSP.STextDocumentPublishDiagnostics $ \msg -> + receiveNotification SMethod_TextDocumentPublishDiagnostics $ \msg -> setDiagnostics $ coerce $ msg ^. LSP.params . LSP.diagnostics -- We allow up to 0.1 s to receive the first batch of diagnostics withTimeout 100_000 $ whileM $ do @@ -157,9 +162,9 @@ (killThread . thd3) $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do req1Done <- newEmptyMVar - req1Id <- sendRequest SShutdown Empty (putMVar req1Done . (._id)) + req1Id <- sendRequest SMethod_Shutdown Nothing (putMVar req1Done . (._id)) req2Done <- newEmptyMVar - req2Id <- sendRequest SShutdown Empty (putMVar req2Done . (._id)) + req2Id <- sendRequest SMethod_Shutdown Nothing (putMVar req2Done . (._id)) withTimeout 100_000 $ takeMVar req1Done `shouldReturn` Just req1Id withTimeout 100_000 $ takeMVar req2Done `shouldReturn` Just req2Id prop "opens and changes virtual documents correctly" $ do @@ -169,7 +174,9 @@ $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do doc <- LSP.createDoc "TestFile.hs" "haskell" "" LSP.documentContents doc `shouldReturn` Just "" - changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "foo\n\nbar"] - LSP.documentContents doc `shouldReturn` Just "foo\n\nbar" + let content :: (IsString s) => s + content = "foo\n\nbar" + changeDoc doc [TextDocumentContentChangeEvent $ InR $ #text .== content] + LSP.documentContents doc `shouldReturn` Just content closeDoc doc LSP.documentContents doc `shouldReturn` Nothing