lsp-client (empty) → 0.1.0.0
raw patch · 12 files changed
+1310/−0 lines, 12 filesdep +Diffdep +Globdep +QuickCheck
Dependencies added: Diff, Glob, QuickCheck, Win32, aeson, aeson-pretty, base, bytestring, co-log-core, data-default, dependent-map, directory, extra, filepath, generic-lens, hashable, hspec, lens, lsp, lsp-client, lsp-types, mtl, process, stm, text, text-rope, unix, unliftio, unordered-containers
Files
- ChangeLog.md +5/−0
- LICENCE +202/−0
- README.md +11/−0
- lsp-client.cabal +99/−0
- src/Language/LSP/Client.hs +128/−0
- src/Language/LSP/Client/Compat.hs +22/−0
- src/Language/LSP/Client/Decoding.hs +91/−0
- src/Language/LSP/Client/Encoding.hs +20/−0
- src/Language/LSP/Client/Exceptions.hs +80/−0
- src/Language/LSP/Client/Session.hs +476/−0
- test/Language/LSP/ClientSpec.hs +175/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for lsp-client++## 0.1.0.0 -- 2023-06-20++* First version.
+ LICENCE view
@@ -0,0 +1,202 @@++ 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.
+ README.md view
@@ -0,0 +1,11 @@+# lsp-client++lsp-client is a Language Server Protocol client.++Notably, it does not use `conduit` to parse incoming messages, but+instead exposes a truly concurrent session, in which messages can be+sent and received asynchronously.++It is part of the [lsp](https://github.com/haskell/lsp) family of+packages, along with [lsp](https://hackage.haskell.org/package/lsp)+and [lsp-types](https://hackage.haskell.org/package/lsp-types).
+ lsp-client.cabal view
@@ -0,0 +1,99 @@+cabal-version: 3.0+name: lsp-client+version: 0.1.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+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++source-repository head+ type: git+ location: https://github.com/ners/lsp-client++common common+ default-language: GHC2021+ ghc-options:+ -Weverything+ -Wno-unsafe+ -Wno-missing-safe-haskell-mode+ -Wno-missing-export-lists+ -Wno-missing-import-lists+ -Wno-missing-kind-signatures+ -Wno-all-missed-specialisations+ default-extensions:+ ApplicativeDo+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveGeneric+ DerivingStrategies+ DerivingVia+ ExplicitNamespaces+ NoImplicitPrelude+ OverloadedLabels+ OverloadedRecordDot+ OverloadedStrings+ RecordWildCards+ RecursiveDo+ TypeFamilies+ ViewPatterns+ build-depends:+ aeson >= 2.0 && < 3,+ base >= 4.16 && < 5,+ bytestring,+ lens >= 5.0,+ lsp-types >= 1.6.0.0,+ unliftio >= 0.2,++library+ import: common+ hs-source-dirs: src+ build-depends:+ Diff,+ Glob,+ aeson-pretty,+ co-log-core,+ data-default,+ dependent-map,+ directory,+ filepath,+ generic-lens,+ hashable,+ lsp,+ mtl,+ stm,+ text,+ text-rope,+ unordered-containers,+ if os(windows)+ build-depends: Win32+ else+ build-depends: unix+ exposed-modules:+ Language.LSP.Client,+ Language.LSP.Client.Compat,+ Language.LSP.Client.Decoding,+ Language.LSP.Client.Encoding,+ Language.LSP.Client.Exceptions,+ Language.LSP.Client.Session,++test-suite spec+ import: common+ ghc-options: -threaded+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ QuickCheck,+ extra,+ hspec,+ lsp-client,+ process,+ other-modules:+ Language.LSP.ClientSpec
+ src/Language/LSP/Client.hs view
@@ -0,0 +1,128 @@+{- |+This module provides utilities to run an LSP `Session` in `IO`.+-}+module Language.LSP.Client where++import Control.Concurrent.STM+import Control.Monad (forever)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Reader (asks, runReaderT)+import Data.ByteString.Lazy qualified as LazyByteString+import Data.Dependent.Map qualified as DMap+import Data.Either (fromLeft)+import Data.Generics.Labels ()+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 UnliftIO (concurrently_, race)+import Prelude++{- | Starts a new session, using the specified handles to communicate with the+server.+-}+runSessionWithHandles+ :: Handle+ -- ^ The input handle: messages sent from the server to the client will be read from here+ -> Handle+ -- ^ The output handle: messages sent by the client will be written here+ -> Session a+ -- ^ Session actions+ -> IO a+runSessionWithHandles input output action = initVFS $ \vfs -> do+ initialState <- defaultSessionState vfs+ flip runReaderT initialState $ do+ actionResult <- race action $ do+ let send = do+ message <- asks outgoing >>= liftIO . atomically . readTQueue+ liftIO $ LazyByteString.hPut output $ encode message+ let receive = do+ serverBytes <- liftIO $ getNextMessage input+ (serverMessage, requestCallback) <-+ asks pendingRequests+ >>= liftIO . atomically . flip stateTVar (decodeFromServerMsg serverBytes)+ handleServerMessage serverMessage+ liftIO requestCallback+ case serverMessage of+ LSP.FromServerMess smethod msg -> case methodType smethod of+ Notification -> do+ handlers :: NotificationMap <- asks notificationHandlers >>= liftIO . readTVarIO+ let NotificationCallback cb = DMap.findWithDefault (NotificationCallback (const $ pure ())) smethod handlers+ liftIO $ cb msg+ _ -> pure ()+ _ -> 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 view
@@ -0,0 +1,22 @@+{-# 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
@@ -0,0 +1,91 @@+{-# LANGUAGE GADTs #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Language.LSP.Client.Decoding where++import Control.Exception (catch, throw)+import Control.Monad (liftM2)+import Data.Aeson (Result (Error, Success), Value, decode)+import Data.Aeson.Types (parse)+import Data.ByteString.Lazy (LazyByteString)+import Data.ByteString.Lazy.Char8 qualified as LazyByteString+import Data.Dependent.Map (DMap)+import Data.Dependent.Map qualified as DMap+import Data.Functor+import Data.Functor.Const+import Data.Functor.Product (Product (Pair))+import Data.IxMap (IxMap)+import Data.IxMap qualified as IxMap+import Data.Maybe (fromJust, fromMaybe)+import Language.LSP.Client.Exceptions+import Language.LSP.Types+import System.IO (Handle, hGetLine)+import System.IO.Error (isEOFError)+import Prelude hiding (id)++{- | Fetches the next message bytes based on+ the Content-Length header+-}+getNextMessage :: Handle -> IO LazyByteString+getNextMessage h = do+ headers <- getHeaders h+ case read . init <$> lookup "Content-Length" headers of+ Nothing -> throw NoContentLengthHeader+ Just size -> LazyByteString.hGet h size++getHeaders :: Handle -> IO [(String, String)]+getHeaders h = do+ l <- catch (hGetLine h) eofHandler+ let (name, val) = span (/= ':') l+ if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h+ where+ eofHandler :: IOError -> a+ eofHandler e+ | isEOFError e = throw UnexpectedServerTermination+ | otherwise = throw e++type RequestMap = IxMap LspId RequestCallback++emptyRequestMap :: RequestMap+emptyRequestMap = IxMap.emptyIxMap++data RequestCallback (m :: Method 'FromClient 'Request) = RequestCallback+ { requestCallback :: ResponseMessage m -> IO ()+ , requestMethod :: SMethod m+ }++type NotificationMap = DMap SMethod NotificationCallback++emptyNotificationMap :: NotificationMap+emptyNotificationMap = mempty++newtype NotificationCallback (m :: Method 'FromServer 'Notification) = NotificationCallback+ { notificationCallback :: Message m -> IO ()+ }++instance Semigroup (NotificationCallback m) where+ (NotificationCallback c1) <> (NotificationCallback c2) = NotificationCallback $ liftM2 (*>) c1 c2++instance Monoid (NotificationCallback m) where+ mempty = NotificationCallback (const $ pure ())++updateRequestMap :: LspId m -> RequestCallback m -> RequestMap -> RequestMap+updateRequestMap = ((fromMaybe (error "updateRequestMap: duplicate key registration") .) .) . IxMap.insertIxMap++appendNotificationCallback :: SMethod m -> NotificationCallback m -> NotificationMap -> NotificationMap+appendNotificationCallback = DMap.insertWith' (<>)++removeNotificationCallback :: SMethod (m :: Method 'FromServer 'Notification) -> NotificationMap -> NotificationMap+removeNotificationCallback = DMap.delete++decodeFromServerMsg :: LazyByteString -> RequestMap -> ((FromServerMessage, IO ()), RequestMap)+decodeFromServerMsg bytes reqMap = unP $ parse p obj+ where+ obj = fromJust $ decode bytes :: Value+ p = parseServerMessage $ \(lid :: LspId m) ->+ 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 (Error e) = error $ "Error decoding " <> show obj <> " :" <> e
+ src/Language/LSP/Client/Encoding.hs view
@@ -0,0 +1,20 @@+module Language.LSP.Client.Encoding where++import Data.Aeson (ToJSON)+import Data.Aeson qualified as Aeson+import Data.ByteString.Lazy (LazyByteString)+import Data.ByteString.Lazy.Char8 qualified as LazyByteString+import Prelude++addHeader :: LazyByteString -> LazyByteString+addHeader content =+ mconcat+ [ "Content-Length: "+ , LazyByteString.pack $ show $ LazyByteString.length content+ , "\r\n"+ , "\r\n"+ , content+ ]++encode :: ToJSON a => a -> LazyByteString+encode = addHeader . Aeson.encode
+ src/Language/LSP/Client/Exceptions.hs view
@@ -0,0 +1,80 @@+module Language.LSP.Client.Exceptions where++import Control.Exception (Exception)+import Data.Aeson (Value, encode)+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.Algorithm.Diff (getGroupedDiff)+import Data.Algorithm.DiffOutput (ppDiff)+import Data.ByteString.Lazy.Char8 qualified as LazyByteString+import Data.List (nub)+import Language.LSP.Types+ ( FromServerMessage+ , ResponseError+ , SomeLspId+ )+import Prelude++-- | An exception that can be thrown during a 'Language.LSP.Client.Session'+data SessionException+ = Timeout (Maybe FromServerMessage)+ | NoContentLengthHeader+ | UnexpectedMessage String FromServerMessage+ | ReplayOutOfOrder FromServerMessage [FromServerMessage]+ | UnexpectedDiagnostics+ | IncorrectApplyEditRequest String+ | UnexpectedResponseError SomeLspId ResponseError+ | UnexpectedServerTermination+ | IllegalInitSequenceMessage FromServerMessage+ | MessageSendError Value IOError+ deriving stock (Eq)++instance Exception SessionException++instance Show SessionException where+ show (Timeout lastMsg) =+ "Timed out waiting to receive a message from the server."+ ++ case lastMsg of+ Just msg -> "\nLast message received:\n" ++ LazyByteString.unpack (encodePretty msg)+ Nothing -> mempty+ show NoContentLengthHeader = "Couldn't read Content-Length header from the server."+ show (UnexpectedMessage expected lastMsg) =+ "Received an unexpected message from the server:\n"+ ++ "Was parsing: "+ ++ expected+ ++ "\n"+ ++ "But the last message received was:\n"+ ++ LazyByteString.unpack (encodePretty lastMsg)+ show (ReplayOutOfOrder received expected) =+ let expected' = nub expected+ getJsonDiff :: FromServerMessage -> [String]+ getJsonDiff = lines . LazyByteString.unpack . encodePretty+ showExp e =+ LazyByteString.unpack (encodePretty e)+ ++ "\nDiff:\n"+ ++ ppDiff (getGroupedDiff (getJsonDiff received) (getJsonDiff e))+ in "Replay is out of order:\n"+ +++ -- Print json so its a bit easier to update the session logs+ "Received from server:\n"+ ++ LazyByteString.unpack (encodePretty received)+ ++ "\n"+ ++ "Raw from server:\n"+ ++ LazyByteString.unpack (encode received)+ ++ "\n"+ ++ "Expected one of:\n"+ ++ unlines (map showExp expected')+ show UnexpectedDiagnostics = "Unexpectedly received diagnostics from the server."+ show (IncorrectApplyEditRequest msgStr) =+ "ApplyEditRequest didn't contain document, instead received:\n"+ ++ msgStr+ show (UnexpectedResponseError lid e) =+ "Received an expected error in a response for id "+ ++ show lid+ ++ ":\n"+ ++ show e+ show UnexpectedServerTermination = "Language server unexpectedly terminated"+ show (IllegalInitSequenceMessage msg) =+ "Received an illegal message between the initialize request and response:\n"+ ++ LazyByteString.unpack (encodePretty msg)+ show (MessageSendError msg e) =+ "IO exception:\n" ++ show e ++ "\narose while trying to send message:\n" ++ LazyByteString.unpack (encodePretty msg)
+ src/Language/LSP/Client/Session.hs view
@@ -0,0 +1,476 @@+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{-|+-}++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.Exception (throw)+import Control.Lens hiding (Empty, List)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Control.Monad.Reader (ReaderT, asks)+import Control.Monad.State (StateT, execState)+import Data.Default (def)+import Data.Foldable (foldl', foldr', forM_, toList)+import Data.Function (on)+import Data.Functor (void)+import Data.Generics.Labels ()+import Data.HashMap.Strict (HashMap)+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.Maybe (fromJust, fromMaybe, mapMaybe)+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.VFS+ ( VFS+ , VfsLog+ , VirtualFile (..)+ , changeFromClientVFS+ , changeFromServerVFS+ , closeVFS+ , lsp_version+ , openVFS+ , vfsMap+ , virtualFileVersion+ )+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++data SessionState = SessionState+ { initialized :: TMVar InitializeResult+ -- ^ The response of the initialization handshake, if any.+ , pendingRequests :: TVar RequestMap+ -- ^ Response callbacks for sent requests waiting for a response. Once a response arrives the request is removed from this map.+ , notificationHandlers :: TVar NotificationMap+ -- ^ Notification callbacks that fire whenever a notification of their type is received.+ , lastRequestId :: TVar Int32+ -- ^ A counter to send each request to the server is sent with a unique ID, allowing us to pair it back with its response.+ , serverCapabilities :: TVar (HashMap Text SomeRegistration)+ -- ^ The capabilities that the server has dynamically registered with us so far.+ , clientCapabilities :: ClientCapabilities+ -- ^ The client capabilities advertised to the server. Not a `TVar` because it does not change during the session.+ , progressTokens :: TVar (HashSet ProgressToken)+ -- ^ Progress messages received from the server.+ , outgoing :: TQueue FromClientMessage+ -- ^ Messages that have been serialised but not yet written to the output handle.+ , vfs :: TVar VFS+ -- ^ Virtual, in-memory file system of the files known to the LSP.+ , rootDir :: FilePath+ -- ^ The root of the project as sent to the server. Document URIs are relative to it. Not a `TVar` because it does not change during the session.+ }++defaultSessionState :: VFS -> IO SessionState+defaultSessionState vfs' = do+ initialized <- newEmptyTMVarIO+ pendingRequests <- newTVarIO emptyRequestMap+ notificationHandlers <- newTVarIO emptyNotificationMap+ lastRequestId <- newTVarIO 0+ serverCapabilities <- newTVarIO mempty+ progressTokens <- newTVarIO mempty+ outgoing <- newTQueueIO+ vfs <- newTVarIO vfs'+ pure+ SessionState+ { rootDir = "."+ , clientCapabilities = def+ , ..+ }++-- | 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+documentChangeUri (InL x) = x ^. textDocument . uri+documentChangeUri (InR (InL x)) = x ^. uri+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 ()++handleServerMessage (FromServerMess SClientRegisterCapability req) = do+ let List newRegs = req ^. params . registrations <&> \sr@(SomeRegistration r) -> (r ^. LSP.id, sr)+ asks serverCapabilities >>= liftIO . flip modifyTVarIO (HashMap.union (HashMap.fromList newRegs))++handleServerMessage (FromServerMess SClientUnregisterCapability req) = do+ let List unRegs = req ^. params . unregisterations <&> (^. LSP.id)+ asks serverCapabilities >>= liftIO . flip modifyTVarIO (flip (foldr' HashMap.delete) unRegs)++handleServerMessage (FromServerMess SWorkspaceApplyEdit r) = do+ -- First, prefer the versioned documentChanges field+ allChangeParams <- case r ^. params . edit . documentChanges of+ Just (List 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+ 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)+ 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+ mergedParams = mergeParams <$> groupedParams++ forM_ mergedParams (sendNotification STextDocumentDidChange)++ -- Update VFS to new document versions+ let sortedVersions = sortBy (compare `on` (^. textDocument . version)) <$> groupedParams+ latestVersions = (^. 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+ )+ sendResponse+ r+ $ Right+ ApplyWorkspaceEditResponseBody+ { _applied = True+ , _failureReason = Nothing+ , _failedChange = Nothing+ }+ where+ logger :: LogAction (StateT VFS Identity) (WithSeverity VfsLog)+ logger = LogAction $ \(WithSeverity msg sev) -> case sev of Error -> error $ show msg; _ -> pure ()+ checkIfNeedsOpened uri = do+ isOpen <- asks vfs >>= liftIO . readTVarIO <&> has (vfsMap . ix (toNormalizedUri uri))++ -- if its not open, open it+ unless isOpen $ do+ contents <- maybe (pure "") (liftIO . Text.readFile) (uriToFilePath uri)+ sendNotification+ STextDocumentDidOpen+ DidOpenTextDocumentParams+ { _textDocument =+ TextDocumentItem+ { _uri = uri+ , _languageId = ""+ , _version = 0+ , _text = contents+ }+ }++ getParamsFromTextDocumentEdit :: TextDocumentEdit -> DidChangeTextDocumentParams+ getParamsFromTextDocumentEdit (TextDocumentEdit docId (List edits)) = do+ DidChangeTextDocumentParams docId (List $ 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)++ getParamsFromDocumentChange :: DocumentChange -> Maybe DidChangeTextDocumentParams+ getParamsFromDocumentChange (InL textDocumentEdit) = Just $ getParamsFromTextDocumentEdit textDocumentEdit+ getParamsFromDocumentChange _ = Nothing++ bumpNewestVersion (VersionedTextDocumentIdentifier uri _) = head <$> textDocumentVersions uri++ -- For a uri returns an infinite list of versions [n,n+1,n+2,...]+ -- where n is the current version+ textDocumentVersions :: Uri -> Session [VersionedTextDocumentIdentifier]+ 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 ..]++ textDocumentEdits uri edits = do+ vers <- textDocumentVersions uri+ pure $ zipWith (\v e -> TextDocumentEdit v (List [InL e])) vers edits++ getChangeParams uri (List edits) = fmap getParamsFromTextDocumentEdit <$> textDocumentEdits uri (reverse 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++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.+sendRequest+ :: forall (m :: Method 'FromClient 'Request)+ . Message m ~ RequestMessage m+ => SMethod m+ -> MessageParams m+ -> (ResponseMessage 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+ 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.+sendResponse+ :: forall (m :: Method 'FromServer 'Request)+ . RequestMessage m+ -> Either ResponseError (ResponseResult m)+ -> Session ()+sendResponse req =+ sendMessage+ . FromClientRsp (req ^. LSP.method)+ . ResponseMessage (req ^. jsonrpc) (Just $ req ^. LSP.id)++-- | Sends a request to the server and synchronously waits for its response.+request+ :: forall (m :: Method 'FromClient 'Request)+ . Message m ~ RequestMessage m+ => SMethod m+ -> MessageParams m+ -> Session (ResponseMessage m)+request method params = do+ done <- liftIO newEmptyMVar+ void $ sendRequest method params $ putMVar done+ liftIO $ takeMVar done++{- | 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+ where+ lid = SomeLspId $ fromJust $ response ^. LSP.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+ => SMethod m+ -> MessageParams m+ -> Session ()+sendNotification m params = do+ let n = NotificationMessage "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)+ _ -> 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.+receiveNotification+ :: forall (m :: Method 'FromServer 'Notification)+ . SMethod m+ -> (Message m -> IO ())+ -> Session ()+receiveNotification method notificationCallback =+ asks notificationHandlers+ >>= liftIO+ . 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.+clearNotificationCallback+ :: forall (m :: Method 'FromServer 'Notification)+ . SMethod m+ -> Session ()+clearNotificationCallback method =+ asks notificationHandlers+ >>= liftIO+ . 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.+initialize :: Session ()+initialize = do+ pid <- liftIO getCurrentProcessID+ response <-+ request+ SInitialize+ InitializeParams+ { _workDoneToken = Nothing+ , _processId = Just $ fromIntegral pid+ , _clientInfo = Just lspClientInfo+ , _rootPath = Nothing+ , _rootUri = Nothing+ , _initializationOptions = Nothing+ , _capabilities = fullCaps+ , _trace = Just TraceOff+ , _workspaceFolders = Nothing+ }+ asks initialized >>= liftIO . atomically . flip putTMVar (getResponseResult response)+ sendNotification SInitialized $ Just InitializedParams++{- | /Creates/ a new text document. This is different from 'openDoc'+ as it sends a @workspace/didChangeWatchedFiles@ notification letting the server+ know that a file was created within the workspace, __provided that the server+ has registered for it__, and the file matches any patterns the server+ registered for.+ It /does not/ actually create a file on disk, but is useful for convincing+ the server that one does exist.+-}+createDoc+ :: FilePath+ -- ^ The path to the document to open, __relative to the root directory__.+ -> Text+ -- ^ The text document's language identifier, e.g. @"haskell"@.+ -> Text+ -- ^ The content of the text document to create.+ -> Session TextDocumentIdentifier+ -- ^ The identifier of the document just created.+createDoc file language contents = do+ serverCaps <- asks serverCapabilities >>= liftIO . readTVarIO+ clientCaps <- asks clientCapabilities+ rootDir <- asks rootDir+ absFile <- liftIO $ canonicalizePath (rootDir </> file)+ let pred :: SomeRegistration -> [Registration 'WorkspaceDidChangeWatchedFiles]+ pred (SomeRegistration r@(Registration _ SWorkspaceDidChangeWatchedFiles _)) = [r]+ pred _ = mempty+ regs :: [Registration '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++ 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++ clientCapsSupports =+ clientCaps+ ^? workspace+ . _Just+ . didChangeWatchedFiles+ . _Just+ . dynamicRegistration+ . _Just+ == Just True+ shouldSend = clientCapsSupports && foldl' (\acc r -> acc || regHits r) False regs++ when shouldSend $+ sendNotification SWorkspaceDidChangeWatchedFiles $+ DidChangeWatchedFilesParams $+ List [FileEvent (filePathToUri (rootDir </> file)) FcCreated]+ openDoc' file language contents++{- | Opens a text document that /exists on disk/, and sends a+ @textDocument/didOpen@ notification to the server.+-}+openDoc :: FilePath -> Text -> Session TextDocumentIdentifier+openDoc file language = do+ rootDir <- asks rootDir+ let fp = rootDir </> file+ contents <- liftIO $ Text.readFile fp+ openDoc' file language contents++{- | This is a variant of `openDoc` that takes the file content as an argument.+ Use this is the file exists /outside/ of the current workspace.+-}+openDoc' :: FilePath -> Text -> Text -> Session TextDocumentIdentifier+openDoc' file language contents = do+ rootDir <- asks rootDir+ let fp = rootDir </> file+ uri = filePathToUri fp+ item = TextDocumentItem uri language 0 contents+ sendNotification STextDocumentDidOpen (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++-- | 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++-- | Gets the Uri for the file relative to the session's root directory.+getDocUri :: FilePath -> Session Uri+getDocUri file = do+ rootDir <- asks rootDir+ let fp = rootDir </> file+ return $ filePathToUri fp++-- | The current text contents of a document.+documentContents :: TextDocumentIdentifier -> Session (Maybe Rope)+documentContents (TextDocumentIdentifier uri) = do+ vfs <- asks vfs >>= liftIO . readTVarIO+ pure $ vfs ^? vfsMap . ix (toNormalizedUri uri) . to _file_text++-- | Adds the current version to the document, as tracked by the session.+getVersionedDoc :: TextDocumentIdentifier -> Session VersionedTextDocumentIdentifier+getVersionedDoc (TextDocumentIdentifier uri) = do+ vfs <- asks vfs >>= liftIO . readTVarIO+ let ver = vfs ^? vfsMap . ix (toNormalizedUri uri) . to virtualFileVersion+ pure $ VersionedTextDocumentIdentifier uri ver
+ test/Language/LSP/ClientSpec.hs view
@@ -0,0 +1,175 @@+module Language.LSP.ClientSpec where++import Control.Arrow ((>>>))+import Control.Exception+import Control.Lens ((^.))+import Control.Monad+import Control.Monad.Extra (whenMaybeM, whileJustM, whileM)+import Data.Aeson ((.:))+import Data.Aeson qualified as Aeson+import Data.Aeson.Types (parseMaybe)+import Data.ByteString (ByteString, hGetSome)+import Data.ByteString.Builder.Extra (defaultChunkSize)+import Data.ByteString.Lazy qualified as LazyByteString+import Data.Coerce (coerce)+import Data.Maybe (fromJust)+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 System.IO+import System.Process (createPipe)+import Test.Hspec hiding (shouldReturn)+import Test.Hspec qualified as Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import UnliftIO (MonadIO (..), MonadUnliftIO, fromEither, newTVarIO, race, readTVarIO)+import UnliftIO.Concurrent+import Prelude hiding (log)++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 delay a = fromEither =<< race timeout a+ where+ timeout = do+ threadDelay delay+ pure $ AssertionFailed "Timeout exceeded"++diagnostic :: Int -> Diagnostic+diagnostic i =+ Diagnostic+ { _range =+ Range+ { _start = Position{_line = 0, _character = 0}+ , _end = Position{_line = 0, _character = 0}+ }+ , _severity = Nothing+ , _code = Just $ InL $ fromIntegral i+ , _source = Nothing+ , _message = ""+ , _tags = Nothing+ , _relatedInformation = Nothing+ }++-- | LSP server that does not read input, and sends dummy diagnostics once per second+diagServer :: IO (Handle, Handle, ThreadId)+diagServer = do+ (inRead, inWrite) <- createPipe+ hSetBuffering inRead LineBuffering+ hSetBuffering inWrite LineBuffering+ (outRead, outWrite) <- createPipe+ hSetBuffering outRead LineBuffering+ hSetBuffering outWrite LineBuffering+ threadId <- forkIO $ forM_ [1 ..] $ \i -> do+ threadDelay 1_000+ let message =+ NotificationMessage+ "2.0"+ STextDocumentPublishDiagnostics+ PublishDiagnosticsParams+ { _uri = Uri ""+ , _version = Nothing+ , _diagnostics = List [diagnostic i]+ }+ LazyByteString.hPut outWrite $ encode message+ pure (inWrite, outRead, threadId)++-- | LSP server that accepts requests and answers them with a delay+reqServer :: IO (Handle, Handle, ThreadId)+reqServer = do+ (inRead, inWrite) <- createPipe+ hSetBuffering inRead LineBuffering+ hSetBuffering inWrite LineBuffering+ (outRead, outWrite) <- createPipe+ hSetBuffering outRead LineBuffering+ hSetBuffering outWrite LineBuffering+ lock <- newMVar ()+ threadId <- forkIO $ forever $ do+ bytes <- liftIO $ getNextMessage inRead+ let obj = fromJust $ Aeson.decode bytes+ idMaybe = parseMaybe (.: "id") obj+ message :: ResponseMessage 'Shutdown+ message = ResponseMessage "2.0" idMaybe (Right Empty)+ forkIO $ do+ threadDelay 1_000+ takeMVar lock+ LazyByteString.hPut outWrite $ encode message+ putMVar lock ()+ pure (inWrite, outRead, threadId)++-- | LSP server that reads messages, and does nothing else+notifServer :: IO (Handle, Handle, ThreadId)+notifServer = do+ (inRead, inWrite) <- createPipe+ hSetBuffering inRead LineBuffering+ hSetBuffering inWrite LineBuffering+ (outRead, _) <- createPipe+ hSetBuffering outRead LineBuffering+ threadId <- forkIO $ forever $ do+ liftIO $ getNextMessage inRead+ pure (inWrite, outRead, threadId)++-- | LSP client that waits for queries+client :: Handle -> Handle -> IO (Session () -> IO (), ThreadId)+client serverInput serverOutput = do+ i <- newEmptyMVar+ o <- newEmptyMVar+ threadId <- forkIO $ runSessionWithHandles serverOutput serverInput $ forever $ do+ a <- takeMVar i+ a >>= putMVar o+ pure (putMVar i >>> (*> readMVar o), threadId)++getAvailableContents :: Handle -> IO ByteString+getAvailableContents h = whileJustM $ whenMaybeM (hReady h) (hGetSome h defaultChunkSize)++spec :: Spec+spec = do+ prop "concurrently handles actions and server messages" $ again $ do+ bracket+ diagServer+ (killThread . thd3)+ $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do+ diagnostics <- newTVarIO @_ @[Diagnostic] []+ let getDiagnostics = readTVarIO diagnostics+ setDiagnostics = writeTVarIO diagnostics+ receiveNotification LSP.STextDocumentPublishDiagnostics $ \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+ threadDelay 1_000+ null <$> getDiagnostics+ [d1] <- getDiagnostics+ -- We allow up to 0.1 s to receive the next batch of diagnostics+ withTimeout 100_000 $ whileM $ do+ threadDelay 1_000+ [d2] <- getDiagnostics+ pure $ d2._code == d1._code+ prop "answers requests correctly" $ again $ do+ bracket+ reqServer+ (killThread . thd3)+ $ \(serverIn, serverOut, _) -> runSessionWithHandles serverOut serverIn $ do+ req1Done <- newEmptyMVar+ req1Id <- sendRequest SShutdown Empty (putMVar req1Done . (._id))+ req2Done <- newEmptyMVar+ req2Id <- sendRequest SShutdown Empty (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+ bracket+ notifServer+ (killThread . thd3)+ $ \(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"+ closeDoc doc+ LSP.documentContents doc `shouldReturn` Nothing
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -Wno-prepositive-qualified-module #-}