lsp-client 0.1.0.0 → 0.2.0.0
raw patch · 13 files changed
+249/−494 lines, 13 filesdep +containersdep +row-typesdep +unix-compatdep −Win32dep −hashabledep −unixdep ~aesondep ~bytestringdep ~lens
Dependencies added: containers, row-types, unix-compat
Dependencies removed: Win32, hashable, unix
Dependency ranges changed: aeson, bytestring, lens, lsp-types, unliftio
Files
- CHANGELOG.md +10/−0
- ChangeLog.md +0/−5
- LICENCE +0/−202
- LICENCE.md +13/−0
- lsp-client.cabal +15/−15
- src/Control/Concurrent/STM/TVar/Extra.hs +16/−0
- src/Language/LSP/Client.hs +10/−79
- src/Language/LSP/Client/Compat.hs +0/−22
- src/Language/LSP/Client/Decoding.hs +9/−8
- src/Language/LSP/Client/Encoding.hs +1/−1
- src/Language/LSP/Client/Exceptions.hs +1/−1
- src/Language/LSP/Client/Session.hs +153/−147
- test/Language/LSP/ClientSpec.hs +21/−14
+ CHANGELOG.md view
@@ -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.
− ChangeLog.md
@@ -1,5 +0,0 @@-# Revision history for lsp-client--## 0.1.0.0 -- 2023-06-20--* First version.
− LICENCE
@@ -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.
+ LICENCE.md view
@@ -0,0 +1,13 @@+Copyright 2024 ners <ners@gmx.ch>++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.
lsp-client.cabal view
@@ -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,
+ src/Control/Concurrent/STM/TVar/Extra.hs view
@@ -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
src/Language/LSP/Client.hs view
@@ -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
− src/Language/LSP/Client/Compat.hs
@@ -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)
src/Language/LSP/Client/Decoding.hs view
@@ -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
src/Language/LSP/Client/Encoding.hs view
@@ -16,5 +16,5 @@ , content ] -encode :: ToJSON a => a -> LazyByteString+encode :: (ToJSON a) => a -> LazyByteString encode = addHeader . Aeson.encode
src/Language/LSP/Client/Exceptions.hs view
@@ -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
src/Language/LSP/Client/Session.hs view
@@ -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
test/Language/LSP/ClientSpec.hs view
@@ -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