lsp 2.3.0.0 → 2.8.0.0
raw patch · 12 files changed
Files
- ChangeLog.md +53/−4
- example/Reactor.hs +14/−15
- example/Simple.hs +1/−1
- lsp.cabal +48/−49
- src/Language/LSP/Diagnostics.hs +13/−5
- src/Language/LSP/Server.hs +7/−1
- src/Language/LSP/Server/Control.hs +269/−83
- src/Language/LSP/Server/Core.hs +231/−191
- src/Language/LSP/Server/Processing.hs +259/−168
- src/Language/LSP/Server/Progress.hs +237/−0
- src/Language/LSP/VFS.hs +95/−140
- test/VspSpec.hs +6/−31
ChangeLog.md view
@@ -1,5 +1,54 @@ # Revision history for lsp +## 2.8.0.0 -- 2026-02-14++- Fix link to swarm LSP server+- Add support for FileOperationOptions+- Replace forkIO with async for server listener+- Graceful server exit+- Add support for setting up language servers to use websockets+- Allow flushing diagnostics by source and uri+- Track closed files in the VFS+- Track the languageId in Virtual File+- Treat undefined and null initialization options the same way+- Relax dependency version bounds++## 2.7.0.1 -- 2024-12-31++- Relax dependency version bounds++## 2.7.0.0 -- 2024-06-06++- Drop dependency on `uuid` and `random`+- Fix handling of `rootPath` in `intializeParams`+- Update to newer `lsp-types`++## 2.6.0.0++- Progress reporting now has a configurable start delay and update delay. This allows+ servers to set up progress reporting for any operation and not worry about spamming+ the user with extremely short-lived progress sessions.++## 2.5.0.0++- The server will now reject messages sent after `shutdown` has been received.+- There is a `shutdownBarrier` member in the server state which can be used to+ conveniently run actions when shutdown is triggered.++## 2.4.0.0++- Server-created progress now will not send reports until and unless the client+ confirms the progress token creation.+- Progress helper functions now can take a progress token provided by the client,+ so client-initiated progress can now be supported properly.+- The server options now allow the user to say whether the server should advertise+ support for client-initiated progress or not.+- The server now dynamically registers for `workspace/didChangeConfiguration`+ notifications, to ensure that newer clients continue to send them.+- Removed `getCompletionPrefix` from the `VFS` module. This is specific to completing+ Haskell identifiers and doesn't belong here. It has already been moved to `ghcide`+ some time ago.+ ## 2.3.0.0 - Fix inference of server capabilities for newer methods (except notebook methods).@@ -16,13 +65,13 @@ - `parseConfig` will now be called on the object corresponding to the configuration section, not the whole object. - New callback for when configuration changes, to allow servers to react.-- The logging of messages sent by the protocol has been disabled, as this can prove +- The logging of messages sent by the protocol has been disabled, as this can prove troublesome for servers that log these to the client: https://github.com/haskell/lsp/issues/447 ## 2.1.0.0 * Fix handling of optional methods.-* `staticHandlers` now takes the client capabilities as an argument. +* `staticHandlers` now takes the client capabilities as an argument. These are static across the lifecycle of the server, so this allows a server to decide at construction e.g. whether to provide handlers for resolve methods depending on whether the client supports it.@@ -199,10 +248,10 @@ `LanguageContextEnv` needed to run an `LspT`, as well as anything else your monad needs. ```haskell-type +type ServerDefinition { ... , doInitialize = \env _req -> pure $ Right env-, interpretHandler = \env -> Iso +, interpretHandler = \env -> Iso (runLspT env) -- how to convert from IO ~> m liftIO -- how to convert from m ~> IO }
example/Reactor.hs view
@@ -1,15 +1,9 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeInType #-}--- So we can keep using the old prettyprinter modules (which have a better--- compatibility range) for now.-{-# OPTIONS_GHC -Wno-deprecations #-} {- | This is an example language server built with haskell-lsp using a 'Reactor'@@ -39,7 +33,6 @@ import Data.Aeson qualified as J import Data.Int (Int32) import Data.Text qualified as T-import Data.Text.Prettyprint.Doc import GHC.Generics (Generic) import Language.LSP.Diagnostics import Language.LSP.Logging (defaultClientLogger)@@ -48,6 +41,7 @@ import Language.LSP.Protocol.Types qualified as LSP import Language.LSP.Server import Language.LSP.VFS+import Prettyprinter import System.Exit import System.IO @@ -221,11 +215,16 @@ let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False) - void $ registerCapability LSP.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do- logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info- let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing- rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing]- responder (Right $ LSP.InL rsp)+ void+ $ registerCapability+ mempty+ LSP.SMethod_TextDocumentCodeLens+ regOpts+ $ \_req responder -> do+ logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info+ let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing+ rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing]+ responder (Right $ LSP.InL rsp) , notificationHandler LSP.SMethod_TextDocumentDidOpen $ \msg -> do let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri fileName = LSP.uriToFilePath doc@@ -247,7 +246,7 @@ logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info mdoc <- getVirtualFile doc case mdoc of- Just (VirtualFile _version str _) -> do+ Just (VirtualFile _version str _ _) -> do logger <& ("Found the virtual file: " <> T.pack (show str)) `WithSeverity` Info Nothing -> do logger <& ("Didn't find anything in the VFS for: " <> T.pack (show doc)) `WithSeverity` Info@@ -313,7 +312,7 @@ logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request- void $ withProgress "Executing some long running command" Cancellable $ \update ->+ void $ withProgress "Executing some long running command" (req ^. LSP.params . LSP.workDoneToken) Cancellable $ \update -> forM [(0 :: LSP.UInt) .. 10] $ \i -> do update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) liftIO $ threadDelay (1 * 1000000)
example/Simple.hs view
@@ -21,7 +21,7 @@ Right (InL (MessageActionItem "Turn on")) -> do let regOpts = CodeLensRegistrationOptions (InR Null) Nothing (Just False) - _ <- registerCapability SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do+ _ <- registerCapability mempty SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do let cmd = Command "Say hello" "lsp-hello-command" Nothing rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] responder $ Right $ InL rsp
lsp.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: lsp-version: 2.3.0.0+version: 2.8.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to@@ -18,7 +18,7 @@ copyright: Alan Zimmerman, 2016-2021 category: Development build-type: Simple-extra-source-files:+extra-doc-files: ChangeLog.md README.md @@ -26,12 +26,14 @@ type: git location: https://github.com/haskell/lsp +common warnings+ ghc-options: -Wall -Wunused-packages -Wno-unticked-promoted-constructors+ library+ import: warnings hs-source-dirs: src- default-language: Haskell2010- default-extensions: ImportQualifiedPost- ghc-options: -Wall -fprint-explicit-kinds-+ default-language: GHC2021+ ghc-options: -fprint-explicit-kinds reexported-modules: , Language.LSP.Protocol.Types , Language.LSP.Protocol.Lens@@ -48,48 +50,47 @@ Language.LSP.Server.Control Language.LSP.Server.Core Language.LSP.Server.Processing+ Language.LSP.Server.Progress - ghc-options: -Wall build-depends:- , aeson >=1.0.0.0- , async >=2.0- , attoparsec- , base >=4.11 && <5- , bytestring- , co-log-core >=0.3.1.0- , containers- , data-default- , directory- , exceptions- , filepath- , hashable- , lens-aeson- , lens >=4.15.2- , lsp-types ^>=2.1- , mtl <2.4- , prettyprinter- , random- , row-types- , sorted-list ^>=0.2.1+ , aeson >=2 && <2.3+ , async ^>=2.2+ , attoparsec ^>=0.14+ , base >=4.11 && <5+ , bytestring >=0.10 && <0.13+ , co-log-core ^>=0.3+ , containers >=0.6 && < 0.9+ , data-default >=0.7 && < 0.9+ , directory ^>=1.3+ , exceptions ^>=0.10+ , extra >=1.7 && < 1.9+ , filepath >=1.4 && < 1.6+ , hashable >=1.4 && < 1.6+ , lens >=5.1 && <5.4+ , lens-aeson ^>=1.2+ , lsp-types ^>=2.4+ , mtl >=2.2 && <2.4+ , prettyprinter ^>=1.7+ , sorted-list >=0.2.1 && < 0.4 , stm ^>=2.5- , text- , text-rope- , transformers >=0.5.6 && <0.7- , unliftio-core >=0.2.0.0- , unordered-containers- , uuid >=1.3+ , text >=1 && <2.2+ , text-rope >=0.2 && <0.4+ , transformers >=0.5 && <0.7+ , unliftio ^>=0.2+ , unliftio-core ^>=0.2+ , unordered-containers ^>=0.2+ , websockets ^>=0.13 executable lsp-demo-reactor-server- main-is: Reactor.hs- hs-source-dirs: example- default-language: Haskell2010- default-extensions: ImportQualifiedPost- ghc-options: -Wall -Wno-unticked-promoted-constructors+ import: warnings+ main-is: Reactor.hs+ hs-source-dirs: example+ default-language: GHC2021 build-depends: , aeson , base , co-log-core- , lens >=4.15.2+ , lens , lsp , prettyprinter , stm@@ -100,11 +101,10 @@ buildable: False executable lsp-demo-simple-server- main-is: Simple.hs- hs-source-dirs: example- default-language: Haskell2010- default-extensions: ImportQualifiedPost- ghc-options: -Wall -Wno-unticked-promoted-constructors+ import: warnings+ main-is: Simple.hs+ hs-source-dirs: example+ default-language: GHC2021 build-depends: , base , lsp@@ -119,6 +119,7 @@ default: False test-suite lsp-test+ import: warnings type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs@@ -132,13 +133,11 @@ , containers , hspec , lsp- , row-types- , sorted-list >=0.2.1 && <0.2.2+ , sorted-list , text , text-rope , unordered-containers build-tool-depends: hspec-discover:hspec-discover- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall- default-language: Haskell2010- default-extensions: ImportQualifiedPost+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: GHC2021
src/Language/LSP/Diagnostics.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {- @@ -13,6 +11,7 @@ StoreItem (..), partitionBySource, flushBySource,+ flushBySourceAndUri, updateDiagnostics, getDiagnosticParamsFor, @@ -43,8 +42,10 @@ type DiagnosticStore = HM.HashMap J.NormalizedUri StoreItem -data StoreItem- = StoreItem (Maybe J.Int32) DiagnosticsBySource+data StoreItem = StoreItem+ { documentVersion :: Maybe J.Int32+ , diagnostics :: DiagnosticsBySource+ } deriving (Show, Eq) type DiagnosticsBySource = Map.Map (Maybe Text) (SL.SortedList J.Diagnostic)@@ -52,7 +53,7 @@ -- --------------------------------------------------------------------- partitionBySource :: [J.Diagnostic] -> DiagnosticsBySource-partitionBySource diags = Map.fromListWith mappend $ map (\d -> (J._source d, (SL.singleton d))) diags+partitionBySource diags = Map.fromListWith mappend $ map (\d -> (J._source d, SL.singleton d)) diags -- --------------------------------------------------------------------- @@ -61,6 +62,13 @@ flushBySource store (Just source) = HM.map remove store where remove (StoreItem mv diags) = StoreItem mv (Map.delete (Just source) diags)++flushBySourceAndUri :: DiagnosticStore -> Maybe Text -> J.NormalizedUri -> DiagnosticStore+flushBySourceAndUri store msource uri = HM.mapWithKey remove store+ where+ remove k item+ | k == uri = item{diagnostics = Map.delete msource $ diagnostics item}+ | otherwise = item -- ---------------------------------------------------------------------
src/Language/LSP/Server.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExplicitNamespaces #-} module Language.LSP.Server ( module Language.LSP.Server.Control,@@ -35,6 +35,10 @@ requestConfigUpdate, tryChangeConfig, + -- * Shutdown+ isShuttingDown,+ waitShuttingDown,+ -- * VFS getVirtualFile, getVirtualFiles,@@ -46,6 +50,7 @@ -- * Diagnostics publishDiagnostics, flushDiagnosticsBySource,+ flushDiagnosticsBySourceAndUri, -- * Progress withProgress,@@ -63,3 +68,4 @@ import Language.LSP.Server.Control import Language.LSP.Server.Core+import Language.LSP.Server.Progress
src/Language/LSP/Server/Control.hs view
@@ -1,24 +1,36 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--- So we can keep using the old prettyprinter modules (which have a better--- compatibility range) for now.-{-# OPTIONS_GHC -Wno-deprecations #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} module Language.LSP.Server.Control ( -- * Running- runServer, runServerWith,- runServerWithHandles,+ runServerWithConfig,+ ServerConfig (..), LspServerLog (..),++ -- ** Using standard 'IO' 'Handle's+ runServer,++ -- ** Using 'Handle's+ runServerWithHandles,+ prependHeader,+ parseHeaders,++ -- ** Using websockets+ WebsocketConfig (..),+ withWebsocket,+ withWebsocketRunServer, ) where import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) import Colog.Core qualified as L import Control.Applicative ((<|>)) import Control.Concurrent+import Control.Concurrent.Async import Control.Concurrent.STM.TChan+import Control.Exception (catchJust, finally, throwIO) import Control.Monad import Control.Monad.IO.Class import Control.Monad.STM@@ -32,25 +44,31 @@ import Data.Text qualified as T import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL-import Data.Text.Prettyprint.Doc import Language.LSP.Logging (defaultClientLogger) import Language.LSP.Protocol.Message import Language.LSP.Server.Core import Language.LSP.Server.Processing qualified as Processing import Language.LSP.VFS+import Network.WebSockets qualified as WS+import Prettyprinter import System.IO+import System.IO.Error (isResourceVanishedError) data LspServerLog = LspProcessingLog Processing.LspProcessingLog | DecodeInitializeError String | HeaderParseFail [String] String | EOF+ | BrokenPipeWhileSending TL.Text -- truncated outgoing message (including header) | Starting+ | ServerStopped | ParsedMsg T.Text | SendMsg TL.Text+ | WebsocketLog WebsocketLog deriving (Show) instance Pretty LspServerLog where+ pretty ServerStopped = "Server stopped" pretty (LspProcessingLog l) = pretty l pretty (DecodeInitializeError err) = vsep@@ -63,9 +81,15 @@ , pretty (intercalate " > " ctxs) <> ": " <+> pretty err ] pretty EOF = "Got EOF"- pretty Starting = "Starting server"+ pretty (BrokenPipeWhileSending msg) =+ vsep+ [ "Broken pipe while sending (client likely closed output handle):"+ , indent 2 (pretty msg)+ ]+ pretty Starting = "Server starting" pretty (ParsedMsg msg) = "---> " <> pretty msg pretty (SendMsg msg) = "<--2-- " <> pretty msg+ pretty (WebsocketLog msg) = "Websocket:" <+> pretty msg -- --------------------------------------------------------------------- @@ -77,19 +101,21 @@ runServer :: forall config. ServerDefinition config -> IO Int runServer = runServerWithHandles- ioLogger- lspLogger+ defaultIOLogger+ defaultLspLogger stdin stdout++defaultIOLogger :: LogAction IO (WithSeverity LspServerLog)+defaultIOLogger = L.cmap (show . prettyMsg) L.logStringStderr where prettyMsg l = "[" <> viaShow (L.getSeverity l) <> "] " <> pretty (L.getMsg l)- ioLogger :: LogAction IO (WithSeverity LspServerLog)- ioLogger = L.cmap (show . prettyMsg) L.logStringStderr- lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)- lspLogger =- let clientLogger = L.cmap (fmap (T.pack . show . pretty)) defaultClientLogger- in clientLogger <> L.hoistLogAction liftIO ioLogger +defaultLspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)+defaultLspLogger =+ let clientLogger = L.cmap (fmap (T.pack . show . pretty)) defaultClientLogger+ in clientLogger <> L.hoistLogAction liftIO defaultIOLogger+ {- | Starts a language server over the specified handles. This function will return once the @exit@ notification is received. -}@@ -114,14 +140,23 @@ let clientIn = BS.hGetSome hin defaultChunkSize - clientOut out = do- BSL.hPut hout out- hFlush hout+ clientOut out =+ catchJust+ (\e -> if isResourceVanishedError e then Just e else Nothing)+ (BSL.hPut hout out >> hFlush hout)+ ( \e -> do+ let txt = TL.toStrict $ TL.take 400 $ TL.decodeUtf8 out -- limit size+ ioLogger <& BrokenPipeWhileSending (TL.fromStrict txt) `WithSeverity` Error+ throwIO e+ ) runServerWith ioLogger logger clientIn clientOut serverDefinition {- | Starts listening and sending requests and responses using the specified I/O.++ Assumes that the client sends (and wants to receive) the Content-Length+ header. If you do not want this to be the case, use 'runServerWithConfig' -} runServerWith :: -- | The logger to use outside the main body of the server where we can't assume the ability to send messages.@@ -129,22 +164,43 @@ -- | The logger to use once the server has started and can successfully send messages. LogAction (LspM config) (WithSeverity LspServerLog) -> -- | Client input.- IO BS.ByteString ->+ IO BS.StrictByteString -> -- | Function to provide output to.- (BSL.ByteString -> IO ()) ->+ (BSL.LazyByteString -> IO ()) -> ServerDefinition config -> IO Int -- exit code-runServerWith ioLogger logger clientIn clientOut serverDefinition = do- ioLogger <& Starting `WithSeverity` Info-- cout <- atomically newTChan :: IO (TChan J.Value)- _rhpid <- forkIO $ sendServer ioLogger cout clientOut+runServerWith ioLogger lspLogger inwards outwards =+ runServerWithConfig ServerConfig{prepareOutwards = prependHeader, parseInwards = parseHeaders, ..} - let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg+-- --------------------------------------------------------------------- - ioLoop ioLogger logger clientIn serverDefinition emptyVFS sendMsg+data ServerConfig config = ServerConfig+ { ioLogger :: LogAction IO (WithSeverity LspServerLog)+ -- ^ The logger to use outside the main body of the server where we can't assume the ability to send messages.+ , lspLogger :: LogAction (LspM config) (WithSeverity LspServerLog)+ -- ^ The logger to use once the server has started and can successfully send messages.+ , inwards :: IO BS.StrictByteString+ -- ^ Client input.+ , outwards :: BSL.LazyByteString -> IO ()+ -- ^ Function to provide output to.+ , prepareOutwards :: BSL.LazyByteString -> BSL.LazyByteString+ -- ^ how to prepare an outgoing response for sending. This can be used, to e.g. prepend the Content-Length header, c.f. 'prependHeader'+ , parseInwards :: Attoparsec.Parser BS.StrictByteString+ -- ^ how to parse the input. This can be used to consume the Content-Length and Content-Type headers, c.f. 'parseHeaders'+ } - return 1+runServerWithConfig ::+ ServerConfig config ->+ ServerDefinition config ->+ IO Int+runServerWithConfig ServerConfig{..} serverDefinition = do+ ioLogger <& Starting `WithSeverity` Info+ cout <- atomically newTChan :: IO (TChan FromServerMessage)+ withAsync (sendServer ioLogger cout outwards prepareOutwards) $ \sendServerAsync -> do+ let sendMsg = atomically . writeTChan cout+ res <- ioLoop ioLogger lspLogger inwards parseInwards serverDefinition emptyVFS sendMsg (wait sendServerAsync)+ ioLogger <& ServerStopped `WithSeverity` Info+ return res -- --------------------------------------------------------------------- @@ -152,62 +208,50 @@ forall config. LogAction IO (WithSeverity LspServerLog) -> LogAction (LspM config) (WithSeverity LspServerLog) ->- IO BS.ByteString ->+ IO BS.StrictByteString ->+ Attoparsec.Parser BS.StrictByteString -> ServerDefinition config -> VFS -> (FromServerMessage -> IO ()) ->- IO ()-ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg = do+ IO () ->+ IO Int+ioLoop ioLogger logger clientIn parser serverDefinition vfs sendMsg waitSenderFinish = do minitialize <- parseOne ioLogger clientIn (parse parser "") case minitialize of- Nothing -> pure ()+ Nothing -> pure 1 Just (msg, remainder) -> do case J.eitherDecode $ BSL.fromStrict msg of- Left err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error+ Left err -> do+ ioLogger <& DecodeInitializeError err `WithSeverity` Error+ return 1 Right initialize -> do- mInitResp <- Processing.initializeRequestHandler pioLogger serverDefinition vfs sendMsg initialize+ mInitResp <- Processing.initializeRequestHandler pioLogger serverDefinition vfs sendMsg waitSenderFinish initialize case mInitResp of- Nothing -> pure ()+ Nothing -> pure 1 Just env -> runLspT env $ loop (parse parser remainder) where pioLogger = L.cmap (fmap LspProcessingLog) ioLogger pLogger = L.cmap (fmap LspProcessingLog) logger - loop :: Result BS.ByteString -> LspM config () loop = go where go r = do- res <- parseOne logger clientIn r- case res of- Nothing -> pure ()- Just (msg, remainder) -> do- Processing.processMessage pLogger $ BSL.fromStrict msg- go (parse parser remainder)-- parser = do- try contentType <|> (return ())- len <- contentLength- try contentType <|> (return ())- _ <- string _ONE_CRLF- Attoparsec.take len-- contentLength = do- _ <- string "Content-Length: "- len <- decimal- _ <- string _ONE_CRLF- return len-- contentType = do- _ <- string "Content-Type: "- skipWhile (/= '\r')- _ <- string _ONE_CRLF- return ()+ b <- isExiting+ if b+ then pure 0+ else do+ res <- parseOne logger clientIn r+ case res of+ Nothing -> pure 1+ Just (msg, remainder) -> do+ Processing.processMessage pLogger $ BSL.fromStrict msg+ go (parse parser remainder) parseOne :: MonadIO m => LogAction m (WithSeverity LspServerLog) ->- IO BS.ByteString ->- Result BS.ByteString ->+ IO BS.StrictByteString ->+ Result BS.StrictByteString -> m (Maybe (BS.ByteString, BS.ByteString)) parseOne logger clientIn = go where@@ -216,11 +260,7 @@ pure Nothing go (Partial c) = do bs <- liftIO clientIn- if BS.null bs- then do- logger <& EOF `WithSeverity` Error- pure Nothing- else go (c bs)+ go (c bs) go (Done remainder msg) = do -- TODO: figure out how to re-enable -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447@@ -229,30 +269,176 @@ -- --------------------------------------------------------------------- +data WebsocketLog+ = WebsocketShutDown+ | WebsocketNewConnection+ | WebsocketConnectionClosed+ | WebsocketPing+ | WebsocketStarted+ | WebsocketIncomingRequest+ | WebsocketOutgoingResponse+ deriving stock (Show)++instance Pretty WebsocketLog where+ pretty l = case l of+ WebsocketPing -> "Ping"+ WebsocketStarted -> "Started Server, waiting for connections"+ WebsocketShutDown -> "Shut down server"+ WebsocketNewConnection -> "New connection established"+ WebsocketIncomingRequest -> "Received request"+ WebsocketConnectionClosed -> "Closed connection to client"+ WebsocketOutgoingResponse -> "Sent response"++-- | 'host' and 'port' of the websocket server to set up+data WebsocketConfig = WebsocketConfig+ { host :: !String+ -- ^ the host of the websocket server, e.g. @"localhost"@+ , port :: !Int+ -- ^ the port of the websocket server, e.g. @8080@+ }++-- | Set up a websocket server, then call call the continuation (in our case this corresponds to the language server) after accepting a connection+withWebsocket ::+ -- | The logger+ LogAction IO (WithSeverity LspServerLog) ->+ -- | The configuration of the websocket server+ WebsocketConfig ->+ -- | invoke the lsp server, passing communication functions+ (IO BS.StrictByteString -> (BSL.LazyByteString -> IO ()) -> IO r) ->+ IO ()+withWebsocket logger conf startLspServer = do+ let wsLogger = L.cmap (fmap WebsocketLog) logger++ WS.runServer (host conf) (port conf) $ \pending -> do+ conn <- WS.acceptRequest pending+ wsLogger <& WebsocketNewConnection `WithSeverity` Debug++ outChan <- newChan+ inChan <- newChan++ let inwards = readChan inChan+ outwards = writeChan outChan++ WS.withPingThread conn 30 (wsLogger <& WebsocketPing `WithSeverity` Debug) $ do+ withAsync (startLspServer inwards outwards) $ \lspAsync ->+ ( do+ link lspAsync++ race_+ ( forever $ do+ msg <- readChan outChan+ wsLogger <& WebsocketOutgoingResponse `WithSeverity` Debug+ WS.sendTextData conn msg+ )+ ( forever $ do+ msg <- WS.receiveData conn+ wsLogger <& WebsocketIncomingRequest `WithSeverity` Debug+ writeChan inChan msg+ -- NOTE: since the parser assumes to consume messages+ -- incrementally,we need to somehow signal that the+ -- content has terminated - we do this by sending the+ -- empty string (instead of parsing exactly the content+ -- length, like in the stdio case)+ writeChan inChan ""+ )+ )+ `finally` do+ wsLogger <& WebsocketConnectionClosed `WithSeverity` Debug++{- | Given a 'WebsocketConfig', wait for connections using a websocket server.+The continuation passed is called for every new connection and can be used+to initialize state that is specific to that respective connection.++This combines 'withWebsocket' and 'runServerWithConfig'.+-}+withWebsocketRunServer ::+ -- | Configuration for the websocket+ WebsocketConfig ->+ -- | How to set up a new 'ServerDefinition' for a specific configuration. z+ -- This is passed as CPS'd 'IO' to allow for setting (- and cleaning) up+ -- a server per websocket connection+ ((ServerDefinition config -> IO Int) -> IO Int) ->+ -- | The 'IO' logger+ LogAction IO (WithSeverity LspServerLog) ->+ -- | The logger that logs in 'LspM' to the client+ LogAction (LspM config) (WithSeverity LspServerLog) ->+ IO ()+withWebsocketRunServer wsConf withLspDefinition ioLogger lspLogger =+ withWebsocket ioLogger wsConf $ \inwards outwards -> do+ withLspDefinition $ \lspDefinition ->+ runServerWithConfig+ ServerConfig+ { ioLogger+ , lspLogger+ , inwards+ , outwards+ , -- NOTE: if you run the language server on websockets, you do not+ -- need to prepend headers to requests and responses, because+ -- the chunking is already handled by the websocket, i.e. there's+ -- no situation where the client or the server has to rely on input/+ -- output chunking+ prepareOutwards = id+ , parseInwards = Attoparsec.takeByteString+ }+ lspDefinition++-- ---------------------------------------------------------------------+ -- | Simple server to make sure all output is serialised-sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan J.Value -> (BSL.ByteString -> IO ()) -> IO ()-sendServer _logger msgChan clientOut = do- forever $ do+sendServer :: LogAction IO (WithSeverity LspServerLog) -> TChan FromServerMessage -> (BSL.LazyByteString -> IO ()) -> (BSL.LazyByteString -> BSL.LazyByteString) -> IO ()+sendServer _logger msgChan clientOut prepareMessage = go+ where+ go = do msg <- atomically $ readTChan msgChan -- We need to make sure we only send over the content of the message, -- and no other tags/wrapper stuff let str = J.encode msg-- let out =- BSL.concat- [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str)- , BSL.fromStrict _TWO_CRLF- , str- ]+ let out = prepareMessage str clientOut out+ -- close the client sender when we send out the shutdown request's response+ case msg of+ FromServerRsp SMethod_Shutdown _ -> pure ()+ _ -> go -- TODO: figure out how to re-enable -- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447 -- logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug -_ONE_CRLF :: BS.ByteString+-- | prepend a Content-Length header to the given message+prependHeader :: BSL.LazyByteString -> BSL.LazyByteString+prependHeader str =+ BSL.concat+ [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str)+ , BSL.fromStrict _TWO_CRLF+ , str+ ]++{- | parse Content-Length and Content-Type headers and then consume+ input with length of the Content-Length+-}+parseHeaders :: Attoparsec.Parser BS.StrictByteString+parseHeaders = do+ try contentType <|> return ()+ len <- contentLength+ try contentType <|> return ()+ _ <- string _ONE_CRLF+ Attoparsec.take len+ where+ contentLength = do+ _ <- string "Content-Length: "+ len <- decimal+ _ <- string _ONE_CRLF+ return len++ contentType = do+ _ <- string "Content-Type: "+ skipWhile (/= '\r')+ _ <- string _ONE_CRLF+ return ()++_ONE_CRLF :: BS.StrictByteString _ONE_CRLF = "\r\n"-_TWO_CRLF :: BS.ByteString+_TWO_CRLF :: BS.StrictByteString _TWO_CRLF = "\r\n\r\n"
src/Language/LSP/Server/Core.hs view
@@ -1,20 +1,13 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE CUSKs #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} {-# OPTIONS_GHC -fprint-explicit-kinds #-} @@ -26,10 +19,9 @@ WithSeverity (..), (<&), )-import Control.Concurrent.Async+import Control.Concurrent.Extra as C import Control.Concurrent.STM-import Control.Exception qualified as E-import Control.Lens (at, (^.), (^?), _Just)+import Control.Lens (ix, (^.), (^?), _Just) import Control.Monad import Control.Monad.Catch ( MonadCatch,@@ -54,10 +46,8 @@ import Data.Maybe import Data.Monoid (Ap (..)) import Data.Ord (Down (Down))-import Data.Row import Data.Text (Text) import Data.Text qualified as T-import Data.UUID qualified as UUID import Language.LSP.Diagnostics import Language.LSP.Protocol.Capabilities import Language.LSP.Protocol.Lens qualified as L@@ -68,9 +58,8 @@ import Language.LSP.Protocol.Utils.Misc (prettyJSON) import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap-import Language.LSP.VFS+import Language.LSP.VFS hiding (end) import Prettyprinter-import System.Random hiding (next) -- --------------------------------------------------------------------- {-# ANN module ("HLint: ignore Eta reduce" :: String) #-}@@ -85,13 +74,15 @@ NewConfig J.Value | ConfigurationParseError J.Value T.Text | ConfigurationNotSupported- | BadConfigurationResponse ResponseError+ | BadConfigurationResponse (TResponseError Method_WorkspaceConfiguration) | WrongConfigSections [J.Value]- deriving (Show)+ | forall m. CantRegister (SMethod m) +deriving instance (Show LspCoreLog)+ instance Pretty LspCoreLog where pretty (NewConfig config) = "LSP: set new config:" <+> prettyJSON config- pretty (ConfigurationNotSupported) = "LSP: not requesting configuration since the client does not support workspace/configuration"+ pretty ConfigurationNotSupported = "LSP: not requesting configuration since the client does not support workspace/configuration" pretty (ConfigurationParseError settings err) = vsep [ "LSP: configuration parse error:"@@ -100,7 +91,8 @@ , prettyJSON settings ] pretty (BadConfigurationResponse err) = "LSP: error when requesting configuration: " <+> pretty err- pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> (prettyJSON $ J.toJSON sections)+ pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> prettyJSON (J.toJSON sections)+ pretty (CantRegister m) = "LSP: can't register dynamically for:" <+> pretty m newtype LspT config m a = LspT {unLspT :: ReaderT (LanguageContextEnv config) m a} deriving (Functor, Applicative, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans, MonadUnliftIO, MonadFix)@@ -141,6 +133,13 @@ resState :: !(LanguageContextState config) , resClientCapabilities :: !L.ClientCapabilities , resRootPath :: !(Maybe FilePath)+ , resProgressStartDelay :: Int+ -- ^ The delay before starting a progress reporting session, in microseconds+ , resProgressUpdateDelay :: Int+ -- ^ The delay between sending progress updates, in microseconds+ , resWaitSender :: !(IO ())+ -- ^ An IO action that waits for the sender thread to finish sending all pending messages.+ -- This is used to ensure all responses are sent before the server exits. See Note [Shutdown] } -- ---------------------------------------------------------------------@@ -181,7 +180,7 @@ from the server or client -} type family Handler (f :: Type -> Type) (m :: Method from t) = (result :: Type) | result -> f t m where- Handler f (m :: Method _from Request) = TRequestMessage m -> (Either ResponseError (MessageResult m) -> f ()) -> f ()+ Handler f (m :: Method _from Request) = TRequestMessage m -> (Either (TResponseError m) (MessageResult m) -> f ()) -> f () Handler f (m :: Method _from Notification) = TNotificationMessage m -> f () -- | How to convert two isomorphic data structures between each other.@@ -214,6 +213,10 @@ , resRegistrationsNot :: !(TVar (RegistrationMap Notification)) , resRegistrationsReq :: !(TVar (RegistrationMap Request)) , resLspId :: !(TVar Int32)+ , resShutdown :: !(C.Barrier ())+ -- ^ Barrier signaled when the server receives the 'shutdown' request. See Note [Shutdown]+ , resExit :: !(C.Barrier ())+ -- ^ Barrier signaled when the server receives the 'exit' notification. See Note [Shutdown] } type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback)@@ -237,24 +240,28 @@ {-# INLINE modifyState #-} modifyState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> (a -> a) -> m () modifyState sel f = do- tvarDat <- sel . resState <$> getLspEnv+ tvarDat <- getStateVar sel liftIO $ atomically $ modifyTVar' tvarDat f {-# INLINE stateState #-} stateState :: MonadLsp config m => (LanguageContextState config -> TVar s) -> (s -> (a, s)) -> m a stateState sel f = do- tvarDat <- sel . resState <$> getLspEnv+ tvarDat <- getStateVar sel liftIO $ atomically $ stateTVar tvarDat f {-# INLINE getsState #-} getsState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m a getsState f = do- tvarDat <- f . resState <$> getLspEnv+ tvarDat <- getStateVar f liftIO $ readTVarIO tvarDat +{-# INLINE getStateVar #-}+getStateVar :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m (TVar a)+getStateVar f = f . resState <$> getLspEnv+ -- --------------------------------------------------------------------- -{- | Language Server Protocol options that the server may configure.+{- | Options that the server may configure. If you set handlers for some requests, you may need to set some of these options. -} data Options = Options@@ -282,8 +289,26 @@ , optExecuteCommandCommands :: Maybe [Text] -- ^ The commands to be executed on the server. -- If you set `executeCommandHandler`, you **must** set this.- , optServerInfo :: Maybe (Rec ("name" .== Text .+ "version" .== Maybe Text))+ , optServerInfo :: Maybe ServerInfo -- ^ Information about the server that can be advertised to the client.+ , optSupportClientInitiatedProgress :: Bool+ -- ^ Whether or not to support client-initiated progress.+ , optProgressStartDelay :: Int+ -- ^ The delay before starting a progress reporting session, in microseconds+ , optProgressUpdateDelay :: Int+ -- ^ The delay between sending progress updates, in microseconds+ , optWorkspaceDidCreateFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceDidCreateFiles' request, in case the language server supports it+ , optWorkspaceWillCreateFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceWillCreateFiles' notification, in case the language server supports it+ , optWorkspaceDidRenameFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceDidRenameFiles' request, in case the language server supports it+ , optWorkspaceWillRenameFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceWillRenameFiles' notification, in case the language server supports it+ , optWorkspaceDidDeleteFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceDidDeleteFiles' request, in case the language server supports it+ , optWorkspaceWillDeleteFileOperationRegistrationOptions :: Maybe FileOperationRegistrationOptions+ -- ^ Options for the 'Method_WorkspaceWillDeleteFiles' notification, in case the language server supports it } instance Default Options where@@ -298,40 +323,28 @@ Nothing Nothing Nothing+ False+ -- See Note [Delayed progress reporting]+ 0+ 0+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing+ Nothing defaultOptions :: Options defaultOptions = def -{- | A package indicating the percentage of progress complete and a- an optional message to go with it during a 'withProgress'-- @since 0.10.0.0--}-data ProgressAmount = ProgressAmount (Maybe UInt) (Maybe Text)--{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session-- @since 0.11.0.0--}-data ProgressCancelledException = ProgressCancelledException- deriving (Show)--instance E.Exception ProgressCancelledException--{- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress'- session-- @since 0.11.0.0--}-data ProgressCancellable = Cancellable | NotCancellable- -- See Note [LSP configuration] for discussion of the configuration-related fields {- | Contains all the callbacks to use for initialized the language server. it is parameterized over a config type variable representing the type for the specific configuration data the language server needs to use. -}-data ServerDefinition config = forall m a.+data ServerDefinition config+ = forall m a. ServerDefinition { defaultConfig :: config -- ^ The default value we initialize the config variable to.@@ -357,7 +370,7 @@ -- the new config. Servers that want to react to config changes should provide -- a callback here, it is not sufficient to just add e.g. a @workspace/didChangeConfiguration@ -- handler.- , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either ResponseError a)+ , doInitialize :: LanguageContextEnv config -> TMessage Method_Initialize -> IO (Either (TResponseError Method_Initialize) a) -- ^ Called *after* receiving the @initialize@ request and *before* -- returning the response. This callback will be invoked to offer the -- language server implementation the chance to create any processes or@@ -392,7 +405,7 @@ request with either an error, or the response params. -} newtype ServerResponseCallback (m :: Method ServerToClient Request)- = ServerResponseCallback (Either ResponseError (MessageResult m) -> IO ())+ = ServerResponseCallback (Either (TResponseError m) (MessageResult m) -> IO ()) {- | Return value signals if response handler was inserted successfully Might fail if the id was already in the map@@ -421,7 +434,7 @@ MonadLsp config f => SServerMethod m -> MessageParams m ->- (Either ResponseError (MessageResult m) -> f ()) ->+ (Either (TResponseError m) (MessageResult m) -> f ()) -> f (LspId m) sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId@@ -441,7 +454,7 @@ getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) getVirtualFile uri = do dat <- vfsData <$> getsState resVFS- pure $ dat ^. vfsMap . at uri+ pure $ dat ^? vfsMap . ix uri . _Open {-# INLINE getVirtualFile #-} getVirtualFiles :: MonadLsp config m => m VFS@@ -479,7 +492,7 @@ let uri = doc ^. L.uri mvf <- getVirtualFile (toNormalizedUri uri) let ver = case mvf of- Just (VirtualFile lspver _ _) -> lspver+ Just (VirtualFile lspver _ _ _) -> lspver Nothing -> 0 return (VersionedTextDocumentIdentifier uri ver) {-# INLINE getVersionedTextDoc #-}@@ -492,7 +505,7 @@ reverseFileMap :: MonadLsp config m => m (FilePath -> FilePath) reverseFileMap = do vfs <- getsState resVFS- let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs+ let f fp = Map.findWithDefault fp fp $ reverseMap vfs return f {-# INLINE reverseFileMap #-} @@ -552,30 +565,27 @@ registerCapability :: forall f t (m :: Method ClientToServer t) config. MonadLsp config f =>+ LogAction f (WithSeverity LspCoreLog) -> SClientMethod m -> RegistrationOptions m -> Handler f m -> f (Maybe (RegistrationToken m))-registerCapability method regOpts f = do- clientCaps <- resClientCapabilities <$> getLspEnv+registerCapability logger method regOpts f = do handlers <- resHandlers <$> getLspEnv let alreadyStaticallyRegistered = case splitClientMethod method of IsClientNot -> SMethodMap.member method $ notHandlers handlers IsClientReq -> SMethodMap.member method $ reqHandlers handlers IsClientEither -> error "Cannot register capability for custom methods"- go clientCaps alreadyStaticallyRegistered+ go alreadyStaticallyRegistered where -- If the server has already registered statically, don't dynamically register -- as per the spec- go _clientCaps True = pure Nothing- go clientCaps False- -- First, check to see if the client supports dynamic registration on this method- | dynamicRegistrationSupported method clientCaps = do- uuid <- liftIO $ UUID.toText <$> getStdRandom random- let registration = L.TRegistration uuid method (Just regOpts)- params = L.RegistrationParams [toUntypedRegistration registration]- regId = RegistrationId uuid- rio <- askUnliftIO+ go True = pure Nothing+ go False = do+ rio <- askUnliftIO+ mtoken <- trySendRegistration logger method regOpts+ case mtoken of+ Just token@(RegistrationToken _ regId) -> do ~() <- case splitClientMethod method of IsClientNot -> modifyState resRegistrationsNot $ \oldRegs -> let pair = Pair regId (ClientMessageHandler (unliftIO rio . f))@@ -585,12 +595,34 @@ in SMethodMap.insert method pair oldRegs IsClientEither -> error "Cannot register capability for custom methods" - -- TODO: handle the scenario where this returns an error- _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure ()+ pure $ Just token+ Nothing -> pure Nothing - pure (Just (RegistrationToken method regId))- | otherwise = pure Nothing+trySendRegistration ::+ forall f t (m :: Method ClientToServer t) config.+ MonadLsp config f =>+ LogAction f (WithSeverity LspCoreLog) ->+ SClientMethod m ->+ RegistrationOptions m ->+ f (Maybe (RegistrationToken m))+trySendRegistration logger method regOpts = do+ clientCaps <- resClientCapabilities <$> getLspEnv+ -- First, check to see if the client supports dynamic registration on this method+ if dynamicRegistrationSupported method clientCaps+ then do+ rid <- T.pack . show <$> freshLspId+ let registration = L.TRegistration rid method (Just regOpts)+ params = L.RegistrationParams [toUntypedRegistration registration]+ regId = RegistrationId rid + -- TODO: handle the scenario where this returns an error+ _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure ()++ pure (Just $ RegistrationToken method regId)+ else do+ logger <& CantRegister SMethod_WorkspaceDidChangeConfiguration `WithSeverity` Warning+ pure Nothing+ {- | Sends a @client/unregisterCapability@ request and removes the handler for that associated registration. -}@@ -605,118 +637,6 @@ params = L.UnregistrationParams [toUntypedUnregistration unregistration] void $ sendRequest SMethod_ClientUnregisterCapability params $ \_res -> pure () ------------------------------------------------------------------------------------ PROGRESS-----------------------------------------------------------------------------------storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m ()-storeProgress n a = modifyState (progressCancel . resProgressData) $ Map.insert n (cancelWith a ProgressCancelledException)-{-# INLINE storeProgress #-}--deleteProgress :: MonadLsp config m => ProgressToken -> m ()-deleteProgress n = modifyState (progressCancel . resProgressData) $ Map.delete n-{-# INLINE deleteProgress #-}---- Get a new id for the progress session and make a new one-getNewProgressId :: MonadLsp config m => m ProgressToken-getNewProgressId = do- stateState (progressNextId . resProgressData) $ \cur ->- let !next = cur + 1- in (L.ProgressToken $ L.InL cur, next)-{-# INLINE getNewProgressId #-}--withProgressBase :: MonadLsp c m => Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a-withProgressBase indefinite title cancellable f = do- progId <- getNewProgressId-- let initialPercentage- | indefinite = Nothing- | otherwise = Just 0- cancellable' = case cancellable of- Cancellable -> True- NotCancellable -> False-- -- Create progress token- -- FIXME : This needs to wait until the request returns before- -- continuing!!!- _ <- sendRequest- SMethod_WindowWorkDoneProgressCreate- (WorkDoneProgressCreateParams progId)- $ \res -> do- case res of- -- An error occurred when the client was setting it up- -- No need to do anything then, as per the spec- Left _err -> pure ()- Right _ -> pure ()-- -- Send the begin and done notifications via 'bracket_' so that they are always fired- res <- withRunInIO $ \runInBase ->- E.bracket_- -- Send begin notification- ( runInBase $- sendNotification SMethod_Progress $- ProgressParams progId $- J.toJSON $- WorkDoneProgressBegin L.AString title (Just cancellable') Nothing initialPercentage- )- -- Send end notification- ( runInBase $- sendNotification SMethod_Progress $- ProgressParams progId $- J.toJSON $- (WorkDoneProgressEnd L.AString Nothing)- )- $ do- -- Run f asynchronously- aid <- async $ runInBase $ f (updater progId)- runInBase $ storeProgress progId aid- wait aid-- -- Delete the progress cancellation from the map- -- If we don't do this then it's easy to leak things as the map contains any IO action.- deleteProgress progId-- return res- where- updater progId (ProgressAmount percentage msg) = do- sendNotification SMethod_Progress $- ProgressParams progId $- J.toJSON $- WorkDoneProgressReport L.AString Nothing msg percentage--clientSupportsProgress :: L.ClientCapabilities -> Bool-clientSupportsProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just-{-# INLINE clientSupportsProgress #-}--{- | Wrapper for reporting progress to the client during a long running- task.- 'withProgress' @title cancellable f@ starts a new progress reporting- session, and finishes it once f is completed.- f is provided with an update function that allows it to report on- the progress during the session.- If @cancellable@ is 'Cancellable', @f@ will be thrown a- 'ProgressCancelledException' if the user cancels the action in- progress.--}-withProgress :: MonadLsp c m => Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a-withProgress title cancellable f = do- clientCaps <- getClientCapabilities- if clientSupportsProgress clientCaps- then withProgressBase False title cancellable f- else f (const $ return ())--{- | Same as 'withProgress', but for processes that do not report the- precentage complete.-- @since 0.10.0.0--}-withIndefiniteProgress :: MonadLsp c m => Text -> ProgressCancellable -> m a -> m a-withIndefiniteProgress title cancellable f = do- clientCaps <- getClientCapabilities- if clientSupportsProgress clientCaps- then withProgressBase True title cancellable (const f)- else f- -- --------------------------------------------------------------------- {- | Aggregate all diagnostics pertaining to a particular version of a document,@@ -757,6 +677,29 @@ -- --------------------------------------------------------------------- +{- | Remove all diagnostics from a particular uri and source, and send the updates to+ the client.+-}+flushDiagnosticsBySourceAndUri ::+ MonadLsp config m =>+ -- | Max number of diagnostics to send+ Int ->+ Maybe Text ->+ NormalizedUri ->+ m ()+flushDiagnosticsBySourceAndUri maxDiagnosticCount msource uri = join $ stateState resDiagnostics $ \oldDiags ->+ let !newDiags = flushBySourceAndUri oldDiags msource uri+ -- Send the updated diagnostics to the client+ act = forM_ (HM.keys newDiags) $ \uri' -> do+ let mdp = getDiagnosticParamsFor maxDiagnosticCount newDiags uri'+ case mdp of+ Nothing -> return ()+ Just params -> do+ sendToClient $ L.fromServerNot $ L.TNotificationMessage "2.0" L.SMethod_TextDocumentPublishDiagnostics params+ in (act, newDiags)++-- ---------------------------------------------------------------------+ {- | The changes in a workspace edit should be applied from the end of the file toward the start. Sort them into this order. -}@@ -819,6 +762,36 @@ Left err -> logger <& BadConfigurationResponse err `WithSeverity` Error else logger <& ConfigurationNotSupported `WithSeverity` Debug +--------------------------------------------------------------------------------+-- CONFIG+--------------------------------------------------------------------------------++-- | Checks if the server has received a 'shutdown' request.+isShuttingDown :: (m ~ LspM config) => m Bool+isShuttingDown = do+ b <- resShutdown . resState <$> getLspEnv+ r <- liftIO $ C.waitBarrierMaybe b+ pure $ case r of+ Just _ -> True+ Nothing -> False++{- | Check if the server has received the 'exit' notification.+See Note [Shutdown]+-}+isExiting :: (m ~ LspM config) => m Bool+isExiting = do+ b <- resExit . resState <$> getLspEnv+ r <- liftIO $ C.waitBarrierMaybe b+ pure $ case r of+ Just () -> True+ Nothing -> False++-- | Blocks until the server receives a 'shutdown' request.+waitShuttingDown :: (m ~ LspM config) => m ()+waitShuttingDown = do+ b <- resShutdown . resState <$> getLspEnv+ liftIO $ C.waitBarrier b+ {- Note [LSP configuration] LSP configuration is a huge mess. - The configuration model of the client is not specified@@ -858,11 +831,78 @@ many clients seem to follow the sensible approach laid out here: https://github.com/microsoft/language-server-protocol/issues/972#issuecomment-626668243 -To make this work, we try to be tolerant by using the following strategy.-When we receive a configuration object from any of the sources above, we first-check to see if it has a field corresponding to our configuration section. If it-does, then we assume that it our config and try to parse it. If it does not, we-try to parse the entire config object. This hopefully lets us handle a variety-of sensible cases where the client sends us mostly our config, either wrapped-in our section or not.+To make this work, we try to be tolerant by using the following strategy. When+we receive a configuration object from any of the sources above, we first check+to see if it has a field corresponding to our configuration section. If it does,+then we assume that it is our config and try to parse it. If it does not parse,+we try to parse the entire config object. This hopefully lets us handle a+variety of sensible cases where the client sends us mostly our config, either+wrapped in our section or not.+-}++{- Note [Client- versus server-initiated progress]+The protocol supports both client- and server-initiated progress. Client-initiated progress+is simpler: the client gives you a progress token, and then you use that to report progress.+Server-initiated progress is more complex: you need to send a request to the client to tell+them about the token you want to use, and only after that can you send updates using it.+-}++{- Note [Delayed progress reporting]+Progress updates can be very noisy by default. There are two ways this can happen:+- Creating progress notifications for very short-lived operations that don't deserve them.+ This directs the user's attention to something that then immediately ceases to exist,+ which is annoying, the more so if it happens frequently.+- Very frequently updating progress information.++Now, in theory the client could deal with this for us. Probably they _should_: working+out how to display an (accurate) series of progress notifications from the server seems+like the client's job. Nonetheless, this does not always happen, and so it is helpful+to moderate the spam.++For this reason we have configurable delays on starting progress tracking and on sending+updates. However, the defaults are set to 0, so it's opt-in.+-}++{- Note [Request cancellation]+Request cancellation is a bit strange.++We need to in fact assume that all requests are cancellable, see+https://github.com/microsoft/language-server-protocol/issues/1159.++The 'cancellable' property that we can set when making progress reports just+affects whether the client should show a 'Cancel' button to the user in the UI.+The client can still always choose to cancel for another reason.+-}++{- Note [Shutdown]+~~~~~~~~~~~~~~~~~~+The LSP protocol has a two-phase shutdown sequence:++1. `shutdown` request: ask the server to stop doing work and finish+ any in-flight operations.+2. `exit` notification: tell the server to terminate the process.++We expose two `Barrier`s to track this state:++- `resShutdown`: signalled when we receive the `shutdown` request.+ Use `isShuttingDown` to check this.+- `resExit`: signalled when we receive the `exit` notification.+ Use `isExiting` to check this.++Shutdown is itself a request, and we assume the client will not send+`exit` before `shutdown`. If you want to be sure that some cleanup has+run before the server exits, make that cleanup part of your customize+`shutdown` handler.++We use a dedicated sender thread to serialise all messages that go to+the client. That thread is set up to stop sending messages after the+`shutdown` response has been sent.++While handling the `shutdown` request we call `resWaitSender` to wait+for the sender thread to flush and finish. Otherwise, we might get a+"broken pipe" error from trying to send messages after the client has+closed our output handle.++After the `shutdown` request has been processed, we do not handle any+more requests or notifications except for `exit`. -}
src/Language/LSP/Server/Processing.hs view
@@ -1,19 +1,8 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeInType #-}--- So we can keep using the old prettyprinter modules (which have a better--- compatibility range) for now.-{-# OPTIONS_GHC -Wno-deprecations #-} -- there's just so much! {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}@@ -28,6 +17,7 @@ (<&), ) +import Control.Concurrent.Extra as C import Control.Concurrent.STM import Control.Exception qualified as E import Control.Lens hiding (Empty)@@ -43,6 +33,7 @@ Null, Options, )+import Data.Aeson qualified as J import Data.Aeson.Lens () import Data.Aeson.Types hiding ( Error,@@ -56,13 +47,10 @@ import Data.List import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map-import Data.Maybe import Data.Monoid-import Data.Row import Data.String (fromString) import Data.Text qualified as T import Data.Text.Lazy.Encoding qualified as TL-import Data.Text.Prettyprint.Doc import Language.LSP.Protocol.Lens qualified as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types@@ -70,7 +58,7 @@ import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap import Language.LSP.Server.Core import Language.LSP.VFS as VFS-import System.Exit+import Prettyprinter data LspProcessingLog = VfsLog VfsLog@@ -78,6 +66,8 @@ | MessageProcessingError BSL.ByteString String | forall m. MissingHandler Bool (SClientMethod m) | ProgressCancel ProgressToken+ | forall m. MessageDuringShutdown (SClientMethod m)+ | ShuttingDown | Exiting deriving instance Show LspProcessingLog@@ -94,11 +84,14 @@ ] pretty (MissingHandler _ m) = "LSP: no handler for:" <+> pretty m pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> pretty tid- pretty Exiting = "LSP: Got exit, exiting"+ pretty (MessageDuringShutdown m) = "LSP: received message during shutdown:" <+> pretty m+ pretty ShuttingDown = "LSP: received shutdown"+ pretty Exiting = "LSP: received exit" processMessage :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> BSL.ByteString -> m () processMessage logger jsonStr = do pendingResponsesVar <- LspT $ asks $ resPendingResponses . resState+ shutdown <- isShuttingDown join $ liftIO $ atomically $ fmap handleErrors $ runExceptT $ do val <- except $ eitherDecode jsonStr pending <- lift $ readTVar pendingResponsesVar@@ -107,8 +100,10 @@ FromClientMess m mess -> pure $ handle logger m mess FromClientRsp (P.Pair (ServerResponseCallback f) (Const !newMap)) res -> do+ -- see Note [Shutdown] writeTVar pendingResponsesVar newMap- pure $ liftIO $ f (res ^. L.result)+ unless shutdown <$> do+ pure $ liftIO $ f (res ^. L.result) where parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap))) parser rm = parseClientMessage $ \i ->@@ -123,15 +118,17 @@ ServerDefinition config -> VFS -> (FromServerMessage -> IO ()) ->+ -- | Action that waits for the sender thread to finish. We use it to set 'LanguageContextEnv.resWaitSender', See Note [Shutdown].+ IO () -> TMessage Method_Initialize -> IO (Maybe (LanguageContextEnv config))-initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do+initializeRequestHandler logger ServerDefinition{..} vfs sendFunc waitSender req = do let sendResp = sendFunc . FromServerRsp SMethod_Initialize handleErr (Left err) = do sendResp $ makeResponseError (req ^. L.id) err pure Nothing handleErr (Right a) = pure $ Just a- flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo+ E.handle (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo let p = req ^. L.params rootDir = getFirst $@@ -140,7 +137,7 @@ [ p ^? L.rootUri . _L >>= uriToFilePath , p ^? L.rootPath . _Just . _L <&> T.unpack ]- clientCaps = (p ^. L.capabilities)+ clientCaps = p ^. L.capabilities let initialWfs = case p ^. L.workspaceFolders of Just (InL xs) -> xs@@ -150,15 +147,17 @@ configObject = lookForConfigSection configSection <$> (p ^. L.initializationOptions) initialConfig <- case configObject of+ -- Treat non-existing "initializationOptions" and `"initializationOptions": null` the same way.+ Nothing -> pure defaultConfig+ Just J.Null -> pure defaultConfig Just o -> case parseConfig defaultConfig o of Right newConfig -> do- liftIO $ logger <& (LspCore $ NewConfig o) `WithSeverity` Debug+ liftIO $ logger <& LspCore (NewConfig o) `WithSeverity` Debug pure newConfig Left err -> do -- Warn not error here, since initializationOptions is pretty unspecified- liftIO $ logger <& (LspCore $ ConfigurationParseError o err) `WithSeverity` Warning+ liftIO $ logger <& LspCore (ConfigurationParseError o err) `WithSeverity` Warning pure defaultConfig- Nothing -> pure defaultConfig stateVars <- liftIO $ do resVFS <- newTVarIO (VFSData vfs mempty)@@ -173,10 +172,24 @@ resRegistrationsNot <- newTVarIO mempty resRegistrationsReq <- newTVarIO mempty resLspId <- newTVarIO 0+ resShutdown <- C.newBarrier+ resExit <- C.newBarrier pure LanguageContextState{..} -- Call the 'duringInitialization' callback to let the server kick stuff up- let env = LanguageContextEnv handlers configSection parseConfig configChanger sendFunc stateVars (p ^. L.capabilities) rootDir+ let env =+ LanguageContextEnv+ handlers+ configSection+ parseConfig+ configChanger+ sendFunc+ stateVars+ (p ^. L.capabilities)+ rootDir+ (optProgressStartDelay options)+ (optProgressUpdateDelay options)+ waitSender configChanger config = forward interpreter (onConfigChange config) handlers = transmuteHandlers interpreter (staticHandlers clientCaps) interpreter = interpretHandler initializationResult@@ -189,9 +202,9 @@ makeResponseMessage rid result = TResponseMessage "2.0" (Just rid) (Right result) makeResponseError origId err = TResponseMessage "2.0" (Just origId) (Left err) - initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a)+ initializeErrorHandler :: (TResponseError Method_Initialize -> IO ()) -> E.SomeException -> IO (Maybe a) initializeErrorHandler sendResp e = do- sendResp $ ResponseError (InR ErrorCodes_InternalError) msg Nothing+ sendResp $ TResponseError (InR ErrorCodes_InternalError) msg Nothing pure Nothing where msg = T.pack $ unwords ["Error on initialize:", show e]@@ -201,42 +214,93 @@ static option. -} inferServerCapabilities :: ClientCapabilities -> Options -> Handlers m -> ServerCapabilities-inferServerCapabilities clientCaps o h =+inferServerCapabilities _clientCaps o h = ServerCapabilities { _textDocumentSync = sync- , _hoverProvider = supportedBool SMethod_TextDocumentHover+ , _hoverProvider =+ supported' SMethod_TextDocumentHover $+ InR $+ HoverOptions clientInitiatedProgress , _completionProvider = completionProvider , _inlayHintProvider = inlayProvider- , _declarationProvider = supportedBool SMethod_TextDocumentDeclaration+ , _declarationProvider =+ supported' SMethod_TextDocumentDeclaration $+ InR $+ InL $+ DeclarationOptions clientInitiatedProgress , _signatureHelpProvider = signatureHelpProvider- , _definitionProvider = supportedBool SMethod_TextDocumentDefinition- , _typeDefinitionProvider = supportedBool SMethod_TextDocumentTypeDefinition- , _implementationProvider = supportedBool SMethod_TextDocumentImplementation- , _referencesProvider = supportedBool SMethod_TextDocumentReferences- , _documentHighlightProvider = supportedBool SMethod_TextDocumentDocumentHighlight- , _documentSymbolProvider = supportedBool SMethod_TextDocumentDocumentSymbol+ , _definitionProvider =+ supported' SMethod_TextDocumentDefinition $+ InR $+ DefinitionOptions clientInitiatedProgress+ , _typeDefinitionProvider =+ supported' SMethod_TextDocumentTypeDefinition $+ InR $+ InL $+ TypeDefinitionOptions clientInitiatedProgress+ , _implementationProvider =+ supported' SMethod_TextDocumentImplementation $+ InR $+ InL $+ ImplementationOptions clientInitiatedProgress+ , _referencesProvider =+ supported' SMethod_TextDocumentReferences $+ InR $+ ReferenceOptions clientInitiatedProgress+ , _documentHighlightProvider =+ supported' SMethod_TextDocumentDocumentHighlight $+ InR $+ DocumentHighlightOptions clientInitiatedProgress+ , _documentSymbolProvider =+ supported' SMethod_TextDocumentDocumentSymbol $+ InR $+ DocumentSymbolOptions clientInitiatedProgress Nothing , _codeActionProvider = codeActionProvider , _codeLensProvider = supported' SMethod_TextDocumentCodeLens $- CodeLensOptions- (Just False)- (supported SMethod_CodeLensResolve)- , _documentFormattingProvider = supportedBool SMethod_TextDocumentFormatting- , _documentRangeFormattingProvider = supportedBool SMethod_TextDocumentRangeFormatting+ CodeLensOptions clientInitiatedProgress (supported SMethod_CodeLensResolve)+ , _documentFormattingProvider =+ supported' SMethod_TextDocumentFormatting $+ InR $+ DocumentFormattingOptions clientInitiatedProgress+ , _documentRangeFormattingProvider =+ supported' SMethod_TextDocumentRangeFormatting $+ InR $+ DocumentRangeFormattingOptions clientInitiatedProgress , _documentOnTypeFormattingProvider = documentOnTypeFormattingProvider- , _renameProvider = renameProvider+ , _renameProvider =+ supported' SMethod_TextDocumentRename $+ InR $+ RenameOptions clientInitiatedProgress (supported SMethod_TextDocumentPrepareRename) , _documentLinkProvider = supported' SMethod_TextDocumentDocumentLink $- DocumentLinkOptions- (Just False)- (supported SMethod_DocumentLinkResolve)- , _colorProvider = supportedBool SMethod_TextDocumentDocumentColor- , _foldingRangeProvider = supportedBool SMethod_TextDocumentFoldingRange+ DocumentLinkOptions clientInitiatedProgress (supported SMethod_DocumentLinkResolve)+ , _colorProvider =+ supported' SMethod_TextDocumentDocumentColor $+ InR $+ InL $+ DocumentColorOptions clientInitiatedProgress+ , _foldingRangeProvider =+ supported' SMethod_TextDocumentFoldingRange $+ InR $+ InL $+ FoldingRangeOptions clientInitiatedProgress , _executeCommandProvider = executeCommandProvider- , _selectionRangeProvider = supportedBool SMethod_TextDocumentSelectionRange- , _callHierarchyProvider = supportedBool SMethod_TextDocumentPrepareCallHierarchy+ , _selectionRangeProvider =+ supported' SMethod_TextDocumentSelectionRange $+ InR $+ InL $+ SelectionRangeOptions clientInitiatedProgress+ , _callHierarchyProvider =+ supported' SMethod_TextDocumentPrepareCallHierarchy $+ InR $+ InL $+ CallHierarchyOptions clientInitiatedProgress , _semanticTokensProvider = semanticTokensProvider- , _workspaceSymbolProvider = supportedBool SMethod_WorkspaceSymbol+ , _workspaceSymbolProvider =+ supported' SMethod_WorkspaceSymbol $+ InR $+ WorkspaceSymbolOptions clientInitiatedProgress (supported SMethod_WorkspaceSymbolResolve) , _workspace = Just workspace , _experimental = Nothing :: Maybe Value , -- The only encoding the VFS supports is the legacy UTF16 option at the moment@@ -245,30 +309,28 @@ supported' SMethod_TextDocumentLinkedEditingRange $ InR $ InL $- LinkedEditingRangeOptions{_workDoneProgress = Nothing}+ LinkedEditingRangeOptions clientInitiatedProgress , _monikerProvider = supported' SMethod_TextDocumentMoniker $ InR $ InL $- MonikerOptions{_workDoneProgress = Nothing}+ MonikerOptions clientInitiatedProgress , _typeHierarchyProvider = supported' SMethod_TextDocumentPrepareTypeHierarchy $ InR $ InL $- TypeHierarchyOptions{_workDoneProgress = Nothing}+ TypeHierarchyOptions clientInitiatedProgress , _inlineValueProvider = supported' SMethod_TextDocumentInlineValue $ InR $ InL $- InlineValueOptions{_workDoneProgress = Nothing}+ InlineValueOptions clientInitiatedProgress , _diagnosticProvider = diagnosticProvider , -- TODO: super unclear what to do about notebooks in general _notebookDocumentSync = Nothing } where- -- \| For when we just return a simple @true@/@false@ to indicate if we- -- support the capability- supportedBool = Just . InL . supported_b+ clientInitiatedProgress = Just (optSupportClientInitiatedProgress o) supported' m b | supported_b m = Just b@@ -286,56 +348,40 @@ singleton :: a -> [a] singleton x = [x] - completionProvider- | supported_b SMethod_TextDocumentCompletion =- Just $- CompletionOptions- { _triggerCharacters = map T.singleton <$> optCompletionTriggerCharacters o- , _allCommitCharacters = map T.singleton <$> optCompletionAllCommitCharacters o- , _resolveProvider = supported SMethod_CompletionItemResolve- , _completionItem = Nothing- , _workDoneProgress = Nothing- }- | otherwise = Nothing-- inlayProvider- | supported_b SMethod_TextDocumentInlayHint =- Just $- InR $- InL- InlayHintOptions- { _workDoneProgress = Nothing- , _resolveProvider = supported SMethod_InlayHintResolve- }- | otherwise = Nothing-- clientSupportsCodeActionKinds =- isJust $- clientCaps ^? L.textDocument . _Just . L.codeAction . _Just . L.codeActionLiteralSupport . _Just+ completionProvider =+ supported' SMethod_TextDocumentCompletion $+ CompletionOptions+ { _triggerCharacters = map T.singleton <$> optCompletionTriggerCharacters o+ , _allCommitCharacters = map T.singleton <$> optCompletionAllCommitCharacters o+ , _resolveProvider = supported SMethod_CompletionItemResolve+ , _completionItem = Nothing+ , _workDoneProgress = clientInitiatedProgress+ } - codeActionProvider- | supported_b SMethod_TextDocumentCodeAction =- Just $- InR $- CodeActionOptions- { _workDoneProgress = Nothing- , _codeActionKinds = codeActionKinds (optCodeActionKinds o)- , _resolveProvider = supported SMethod_CodeActionResolve- }- | otherwise = Just (InL False)+ inlayProvider =+ supported' SMethod_TextDocumentInlayHint $+ InR $+ InL+ InlayHintOptions+ { _workDoneProgress = clientInitiatedProgress+ , _resolveProvider = supported SMethod_InlayHintResolve+ } - codeActionKinds (Just ks)- | clientSupportsCodeActionKinds = Just ks- codeActionKinds _ = Nothing+ codeActionProvider =+ supported' SMethod_TextDocumentCodeAction $+ InR $+ CodeActionOptions+ { _workDoneProgress = clientInitiatedProgress+ , _codeActionKinds = optCodeActionKinds o+ , _resolveProvider = supported SMethod_CodeActionResolve+ } - signatureHelpProvider- | supported_b SMethod_TextDocumentSignatureHelp =- Just $- SignatureHelpOptions- Nothing- (map T.singleton <$> optSignatureHelpTriggerCharacters o)- (map T.singleton <$> optSignatureHelpRetriggerCharacters o)- | otherwise = Nothing+ signatureHelpProvider =+ supported' SMethod_TextDocumentSignatureHelp $+ SignatureHelpOptions+ clientInitiatedProgress+ (map T.singleton <$> optSignatureHelpTriggerCharacters o)+ (map T.singleton <$> optSignatureHelpRetriggerCharacters o) documentOnTypeFormattingProvider | supported_b SMethod_TextDocumentOnTypeFormatting@@ -347,54 +393,51 @@ error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" | otherwise = Nothing - executeCommandProvider- | supported_b SMethod_WorkspaceExecuteCommand- , Just cmds <- optExecuteCommandCommands o =- Just (ExecuteCommandOptions Nothing cmds)- | supported_b SMethod_WorkspaceExecuteCommand- , Nothing <- optExecuteCommandCommands o =- error "executeCommandCommands needs to be set if a executeCommandHandler is set"- | otherwise = Nothing-- clientSupportsPrepareRename =- fromMaybe False $- clientCaps ^? L.textDocument . _Just . L.rename . _Just . L.prepareSupport . _Just-- renameProvider- | clientSupportsPrepareRename- , supported_b SMethod_TextDocumentRename- , supported_b SMethod_TextDocumentPrepareRename =- Just $- InR . RenameOptions Nothing . Just $- True- | supported_b SMethod_TextDocumentRename = Just (InL True)- | otherwise = Just (InL False)+ executeCommandProvider =+ supported' SMethod_WorkspaceExecuteCommand $+ case optExecuteCommandCommands o of+ Just cmds -> ExecuteCommandOptions clientInitiatedProgress cmds+ Nothing -> error "executeCommandCommands needs to be set if a executeCommandHandler is set" -- Always provide the default legend -- TODO: allow user-provided legend via 'Options', or at least user-provided types- semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider+ semanticTokensProvider =+ Just $+ InL $+ SemanticTokensOptions clientInitiatedProgress defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider semanticTokenRangeProvider | supported_b SMethod_TextDocumentSemanticTokensRange = Just $ InL True | otherwise = Nothing semanticTokenFullProvider- | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ #delta .== supported SMethod_TextDocumentSemanticTokensFullDelta+ | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ SemanticTokensFullDelta{_delta = supported SMethod_TextDocumentSemanticTokensFullDelta} | otherwise = Nothing sync = case optTextDocumentSync o of Just x -> Just (InL x) Nothing -> Nothing - workspace = #workspaceFolders .== workspaceFolder .+ #fileOperations .== Nothing+ workspace = WorkspaceOptions{_workspaceFolders = workspaceFolder, _fileOperations = Just fileOperations}+ workspaceFolder = supported' SMethod_WorkspaceDidChangeWorkspaceFolders $ -- sign up to receive notifications WorkspaceFoldersServerCapabilities (Just True) (Just (InR True)) + fileOperations =+ FileOperationOptions+ { _didCreate = join $ supported' SMethod_WorkspaceDidCreateFiles $ optWorkspaceDidCreateFileOperationRegistrationOptions o+ , _willCreate = join $ supported' SMethod_WorkspaceWillCreateFiles $ optWorkspaceWillCreateFileOperationRegistrationOptions o+ , _didRename = join $ supported' SMethod_WorkspaceDidRenameFiles $ optWorkspaceDidRenameFileOperationRegistrationOptions o+ , _willRename = join $ supported' SMethod_WorkspaceWillRenameFiles $ optWorkspaceWillRenameFileOperationRegistrationOptions o+ , _didDelete = join $ supported' SMethod_WorkspaceDidDeleteFiles $ optWorkspaceDidDeleteFileOperationRegistrationOptions o+ , _willDelete = join $ supported' SMethod_WorkspaceWillDeleteFiles $ optWorkspaceWillDeleteFileOperationRegistrationOptions o+ }+ diagnosticProvider = supported' SMethod_TextDocumentDiagnostic $ InL $ DiagnosticOptions- { _workDoneProgress = Nothing+ { _workDoneProgress = clientInitiatedProgress , _identifier = Nothing , -- TODO: this is a conservative but maybe inaccurate, unclear how much it matters _interFileDependencies = True@@ -404,13 +447,28 @@ {- | Invokes the registered dynamic or static handlers for the given message and method, as well as doing some bookkeeping. -}-handle :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m ()+handle :: forall m config meth. (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m () handle logger m msg = case m of SMethod_WorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg -- See Note [LSP configuration]- SMethod_Initialized -> handle' logger (Just $ \_ -> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg+ SMethod_Initialized -> handle' logger (Just $ \_ -> initialDynamicRegistrations logger >> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg+ SMethod_Exit -> handle' logger (Just $ \_ -> signalExit) m msg+ where+ signalExit :: LspM config ()+ signalExit = do+ logger <& Exiting `WithSeverity` Info+ b <- resExit . resState <$> getLspEnv+ liftIO $ signalBarrier b ()+ SMethod_Shutdown -> handle' logger (Just $ \_ -> signalShutdown) m msg+ where+ -- See Note [Shutdown]+ signalShutdown :: LspM config ()+ signalShutdown = do+ logger <& ShuttingDown `WithSeverity` Info+ b <- resShutdown . resState <$> getLspEnv+ liftIO $ signalBarrier b () SMethod_TextDocumentDidOpen -> handle' logger (Just $ vfsFunc logger openVFS) m msg SMethod_TextDocumentDidChange -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg SMethod_TextDocumentDidClose -> handle' logger (Just $ vfsFunc logger closeVFS) m msg@@ -428,55 +486,57 @@ TClientMessage meth -> m () handle' logger mAction m msg = do- maybe (return ()) (\f -> f msg) mAction+ shutdown <- isShuttingDown+ -- These are the methods that we are allowed to process during shutdown.+ -- The reason that we do not include 'shutdown' itself here is because+ -- by the time we get the first 'shutdown' message, isShuttingDown will+ -- still be false, so we would still be able to process it.+ -- This ensures we won't process the second 'shutdown' message and only+ -- process 'exit' during shutdown.+ let allowedMethod m = case (splitClientMethod m, m) of+ (IsClientNot, SMethod_Exit) -> True+ _ -> False + case mAction of+ Just f | not shutdown || allowedMethod m -> f msg+ _ -> pure ()+ dynReqHandlers <- getsState resRegistrationsReq dynNotHandlers <- getsState resRegistrationsNot env <- getLspEnv let Handlers{reqHandlers, notHandlers} = resHandlers env - let mkRspCb :: TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> IO ()- mkRspCb req (Left err) =- runLspT env $- sendToClient $- FromServerRsp (req ^. L.method) $- TResponseMessage "2.0" (Just (req ^. L.id)) (Left err)- mkRspCb req (Right rsp) =- runLspT env $- sendToClient $- FromServerRsp (req ^. L.method) $- TResponseMessage "2.0" (Just (req ^. L.id)) (Right rsp)- case splitClientMethod m of+ -- See Note [Shutdown]+ IsClientNot | shutdown, not (allowedMethod m) -> notificationDuringShutdown IsClientNot -> case pickHandler dynNotHandlers notHandlers of Just h -> liftIO $ h msg Nothing | SMethod_Exit <- m -> exitNotificationHandler logger msg- | otherwise -> do- reportMissingHandler+ | otherwise -> missingNotificationHandler+ -- See Note [Shutdown]+ IsClientReq | shutdown, not (allowedMethod m) -> requestDuringShutdown msg IsClientReq -> case pickHandler dynReqHandlers reqHandlers of- Just h -> liftIO $ h msg (mkRspCb msg)+ Just h | SMethod_Shutdown <- m -> do+ waitSender <- resWaitSender <$> getLspEnv+ liftIO $ h msg (runLspT env . sendResponse msg)+ liftIO waitSender+ Just h -> liftIO $ h msg (runLspT env . sendResponse msg) Nothing- | SMethod_Shutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg)- | otherwise -> do- let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m]- err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing- sendToClient $- FromServerRsp (msg ^. L.method) $- TResponseMessage "2.0" (Just (msg ^. L.id)) (Left err)+ | SMethod_Shutdown <- m -> liftIO $ shutdownRequestHandler msg (runLspT env . sendResponse msg)+ | otherwise -> missingRequestHandler msg IsClientEither -> case msg of+ -- See Note [Shutdown]+ NotMess _ | shutdown -> notificationDuringShutdown NotMess noti -> case pickHandler dynNotHandlers notHandlers of Just h -> liftIO $ h noti- Nothing -> reportMissingHandler+ Nothing -> missingNotificationHandler+ -- See Note [Shutdown]+ ReqMess req | shutdown -> requestDuringShutdown req ReqMess req -> case pickHandler dynReqHandlers reqHandlers of- Just h -> liftIO $ h req (mkRspCb req)- Nothing -> do- let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m]- err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing- sendToClient $- FromServerRsp (req ^. L.method) $- TResponseMessage "2.0" (Just (req ^. L.id)) (Left err)+ Just h -> liftIO $ h req (runLspT env . sendResponse req)+ Nothing -> missingRequestHandler req where -- \| Checks to see if there's a dynamic handler, and uses it in favour of the -- static handler, if it exists.@@ -486,14 +546,32 @@ (Nothing, Just (ClientMessageHandler h)) -> Just h (Nothing, Nothing) -> Nothing + sendResponse :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> Either (TResponseError m1) (MessageResult m1) -> m ()+ sendResponse req res = sendToClient $ FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) res++ requestDuringShutdown :: forall m1. TRequestMessage (m1 :: Method ClientToServer Request) -> m ()+ requestDuringShutdown req = do+ logger <& MessageDuringShutdown m `WithSeverity` Warning+ sendResponse req (Left (TResponseError (InR ErrorCodes_InvalidRequest) "Server is shutdown" Nothing))++ notificationDuringShutdown :: m ()+ notificationDuringShutdown = logger <& MessageDuringShutdown m `WithSeverity` Warning+ -- '$/' notifications should/could be ignored by server. -- Don't log errors in that case. -- See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#-notifications-and-requests.- reportMissingHandler :: m ()- reportMissingHandler =+ missingNotificationHandler :: m ()+ missingNotificationHandler = let optional = isOptionalMethod (SomeMethod m) in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error + missingRequestHandler :: TRequestMessage (m1 :: Method ClientToServer Request) -> m ()+ missingRequestHandler req = do+ logger <& MissingHandler False m `WithSeverity` Error+ let errorMsg = T.pack $ unwords ["No handler for: ", show m]+ err = TResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing+ sendResponse req (Left err)+ progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WindowWorkDoneProgressCancel -> m () progressCancelHandler logger (TNotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do pdata <- getsState (progressCancel . resProgressData)@@ -504,14 +582,27 @@ liftIO cancelAction exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Method_Exit-exitNotificationHandler logger _ = do- logger <& Exiting `WithSeverity` Info- liftIO exitSuccess+exitNotificationHandler _logger _ = do+ -- default exit handler do nothing+ return () -- | Default Shutdown handler shutdownRequestHandler :: Handler IO Method_Shutdown shutdownRequestHandler _req k = do k $ Right Null++initialDynamicRegistrations :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> m ()+initialDynamicRegistrations logger = do+ section <- LspT $ asks resConfigSection+ -- We need to register for `workspace/didChangeConfiguration` dynamically in order to+ -- ensure we receive notifications. See+ -- https://microsoft.github.io/language-server-protocol/specifications/lsp/3.17/specification/#workspace_configuration+ -- https://github.com/microsoft/language-server-protocol/issues/1888+ void $+ trySendRegistration+ (cmap (fmap LspCore) logger)+ SMethod_WorkspaceDidChangeConfiguration+ (DidChangeConfigurationRegistrationOptions (Just $ InL section)) {- | Try to find the configuration section in an object that might represent "all" the settings. The heuristic we use is to look for a property with the right name, and use that if we find
+ src/Language/LSP/Server/Progress.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE LambdaCase #-}++module Language.LSP.Server.Progress (+ withProgress,+ withIndefiniteProgress,+ ProgressAmount (..),+ ProgressCancellable (..),+ ProgressCancelledException,+) where++import Control.Concurrent.Async+import Control.Concurrent.Extra as C+import Control.Concurrent.STM+import Control.Exception qualified as E+import Control.Lens hiding (Empty)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Data.Aeson qualified as J+import Data.Foldable+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Text (Text)+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Protocol.Types qualified as L+import Language.LSP.Server.Core+import UnliftIO qualified as U+import UnliftIO.Exception qualified as UE++{- | A package indicating the percentage of progress complete and a+ an optional message to go with it during a 'withProgress'++ @since 0.10.0.0+-}+data ProgressAmount = ProgressAmount (Maybe UInt) (Maybe Text)++{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session++ @since 0.11.0.0+-}+data ProgressCancelledException = ProgressCancelledException+ deriving (Show)++instance E.Exception ProgressCancelledException++{- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress'+ session++ @since 0.11.0.0+-}+data ProgressCancellable = Cancellable | NotCancellable++-- Get a new id for the progress session and make a new one+getNewProgressId :: MonadLsp config m => m ProgressToken+getNewProgressId = do+ stateState (progressNextId . resProgressData) $ \cur ->+ let !next = cur + 1+ in (L.ProgressToken $ L.InL cur, next)+{-# INLINE getNewProgressId #-}++withProgressBase ::+ forall c m a.+ MonadLsp c m =>+ Bool ->+ Text ->+ Maybe ProgressToken ->+ ProgressCancellable ->+ ((ProgressAmount -> m ()) -> m a) ->+ m a+withProgressBase indefinite title clientToken cancellable f = do+ let initialProgress = ProgressAmount (if indefinite then Nothing else Just 0) Nothing+ LanguageContextEnv{resProgressStartDelay = startDelay, resProgressUpdateDelay = updateDelay} <- getLspEnv++ tokenVar <- liftIO newEmptyTMVarIO+ reportVar <- liftIO $ newTMVarIO initialProgress+ endBarrier <- liftIO newEmptyMVar++ let+ updater :: ProgressAmount -> m ()+ updater pa = liftIO $ atomically $ do+ -- I don't know of a way to do this with a normal MVar!+ -- That is: put something into it regardless of whether it is full or empty+ _ <- tryTakeTMVar reportVar+ putTMVar reportVar pa++ progressEnded :: IO ()+ progressEnded = readMVar endBarrier++ endProgress :: IO ()+ endProgress = void $ tryPutMVar endBarrier ()++ -- Once we have a 'ProgressToken', store it in the variable and also register the cancellation+ -- handler.+ registerToken :: ProgressToken -> m ()+ registerToken t = do+ handlers <- getProgressCancellationHandlers+ liftIO $ atomically $ do+ putTMVar tokenVar t+ modifyTVar handlers (Map.insert t endProgress)++ -- Deregister our 'ProgressToken', specifically its cancellation handler. It is important+ -- to do this reliably or else we will leak handlers.+ unregisterToken :: m ()+ unregisterToken = do+ handlers <- getProgressCancellationHandlers+ liftIO $ atomically $ do+ mt <- tryReadTMVar tokenVar+ for_ mt $ \t -> modifyTVar handlers (Map.delete t)++ -- Find and register our 'ProgressToken', asking the client for it if necessary.+ -- Note that this computation may terminate before we get the token, we need to wait+ -- for the token var to be filled if we want to use it.+ createToken :: m ()+ createToken = do+ -- See Note [Delayed progress reporting]+ -- This delays the creation of the token as well as the 'begin' message. Creating+ -- the token shouldn't result in any visible action on the client side since+ -- the title/initial percentage aren't given until the 'begin' mesage. However,+ -- it's neater not to create tokens that we won't use, and clients may find it+ -- easier to clean them up if they receive begin/end reports for them.+ liftIO $ threadDelay startDelay+ case clientToken of+ -- See Note [Client- versus server-initiated progress]+ -- Client-initiated progress+ Just t -> registerToken t+ -- Try server-initiated progress+ Nothing -> do+ t <- getNewProgressId+ clientCaps <- getClientCapabilities++ -- If we don't have a progress token from the client and+ -- the client doesn't support server-initiated progress then+ -- there's nothing to do: we can't report progress.+ when (clientSupportsServerInitiatedProgress clientCaps)+ $ void+ $+ -- Server-initiated progress+ -- See Note [Client- versus server-initiated progress]+ sendRequest+ SMethod_WindowWorkDoneProgressCreate+ (WorkDoneProgressCreateParams t)+ $ \case+ -- Successfully registered the token, we can now use it.+ -- So we go ahead and start. We do this as soon as we get the+ -- token back so the client gets feedback ASAP+ Right _ -> registerToken t+ -- The client sent us an error, we can't use the token.+ Left _err -> pure ()++ -- Actually send the progress reports.+ sendReports :: m ()+ sendReports = do+ t <- liftIO $ atomically $ readTMVar tokenVar+ begin t+ -- Once we are sending updates, if we get interrupted we should send+ -- the end notification+ update t `UE.finally` end t+ where+ cancellable' = case cancellable of+ Cancellable -> Just True+ NotCancellable -> Just False+ begin t = do+ (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar+ sendProgressReport t $ WorkDoneProgressBegin L.AString title cancellable' msg pct+ update t =+ forever $ do+ -- See Note [Delayed progress reporting]+ liftIO $ threadDelay updateDelay+ (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar+ sendProgressReport t $ WorkDoneProgressReport L.AString Nothing msg pct+ end t = sendProgressReport t (WorkDoneProgressEnd L.AString Nothing)++ -- Create the token and then start sending reports; all of which races with the check for the+ -- progress having ended. In all cases, make sure to unregister the token at the end.+ progressThreads :: m ()+ progressThreads =+ ((createToken >> sendReports) `UE.finally` unregisterToken) `U.race_` liftIO progressEnded++ withRunInIO $ \runInBase -> do+ withAsync (runInBase $ f updater) $ \mainAct ->+ -- If the progress gets cancelled then we need to get cancelled too+ withAsync (runInBase progressThreads) $ \pthreads -> do+ r <- waitEither mainAct pthreads+ -- TODO: is this weird? I can't see how else to gracefully use the ending barrier+ -- as a guard to cancel the other async+ case r of+ Left a -> pure a+ Right _ -> cancelWith mainAct ProgressCancelledException >> wait mainAct+ where+ sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m ()+ sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report++ getProgressCancellationHandlers :: m (TVar (Map.Map ProgressToken (IO ())))+ getProgressCancellationHandlers = getStateVar (progressCancel . resProgressData)++clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool+clientSupportsServerInitiatedProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just+{-# INLINE clientSupportsServerInitiatedProgress #-}++{- |+Wrapper for reporting progress to the client during a long running task.+-}+withProgress ::+ MonadLsp c m =>+ -- | The title of the progress operation+ Text ->+ -- | The progress token provided by the client in the method params, if any+ Maybe ProgressToken ->+ -- | Whether or not this operation is cancellable. If true, the user will be+ -- shown a button to allow cancellation. Note that requests can still be cancelled+ -- even if this is not set.+ ProgressCancellable ->+ -- | An update function to pass progress updates to+ ((ProgressAmount -> m ()) -> m a) ->+ m a+withProgress title clientToken cancellable f = withProgressBase False title clientToken cancellable f++{- |+Same as 'withProgress', but for processes that do not report the precentage complete.+-}+withIndefiniteProgress ::+ MonadLsp c m =>+ -- | The title of the progress operation+ Text ->+ -- | The progress token provided by the client in the method params, if any+ Maybe ProgressToken ->+ -- | Whether or not this operation is cancellable. If true, the user will be+ -- shown a button to allow cancellation. Note that requests can still be cancelled+ -- even if this is not set.+ ProgressCancellable ->+ -- | An update function to pass progress updates to+ ((Text -> m ()) -> m a) ->+ m a+withIndefiniteProgress title clientToken cancellable f =+ withProgressBase True title clientToken cancellable (\update -> f (\msg -> update (ProgressAmount Nothing (Just msg))))
src/Language/LSP/VFS.hs view
@@ -1,20 +1,11 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-}--- So we can keep using the old prettyprinter modules (which have a better--- compatibility range) for now.-{-# OPTIONS_GHC -Wno-deprecations #-} {- | Handles the "Language.LSP.Types.TextDocumentDidChange" \/@@ -27,11 +18,19 @@ VFS (..), vfsMap, VirtualFile (..),+ ClosedVirtualFile (..),+ VirtualFileEntry (..), lsp_version, file_version, file_text,+ language_id,+ _Open,+ _Closed, virtualFileText, virtualFileVersion,+ virtualFileLanguageKind,+ closedVirtualFileLanguageKind,+ virtualFileEntryLanguageKind, VfsLog (..), -- * Managing the VFS@@ -56,8 +55,6 @@ -- * manipulating the file contents rangeLinesFromVfs,- PosPrefixInfo (..),- getCompletionPrefix, -- * for tests applyChanges,@@ -69,25 +66,22 @@ import Control.Lens hiding (parts, (<.>)) import Control.Monad import Control.Monad.State-import Data.Char (isAlphaNum, isUpper) import Data.Foldable (traverse_) import Data.Hashable import Data.Int (Int32) import Data.List import Data.Map.Strict qualified as Map-import Data.Maybe import Data.Ord-import Data.Row import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T-import Data.Text.Prettyprint.Doc hiding (line)-import Data.Text.Rope qualified as URope-import Data.Text.Utf16.Rope (Rope)-import Data.Text.Utf16.Rope qualified as Rope+import Data.Text.Utf16.Lines as Utf16 (Position (..))+import Data.Text.Utf16.Rope.Mixed (Rope)+import Data.Text.Utf16.Rope.Mixed qualified as Rope import Language.LSP.Protocol.Lens qualified as J import Language.LSP.Protocol.Message qualified as J import Language.LSP.Protocol.Types qualified as J+import Prettyprinter hiding (line) import System.Directory import System.FilePath import System.IO@@ -106,16 +100,36 @@ -- remains in the map. , _file_text :: !Rope -- ^ The full contents of the document+ , _language_id :: !(Maybe J.LanguageKind)+ -- ^ The text document's language identifier+ -- This is a Maybe, since when we use the VFS as a client+ -- we don't have this information, since server sends WorkspaceEdit+ -- notifications without a language kind.+ -- When using the VFS in a server, this should always be Just. } deriving (Show) +{- | Represents a closed file in the VFS+We are keeping track of this in order to be able to get information+on virtual files after they were closed.+-}+data ClosedVirtualFile = ClosedVirtualFile+ { _language_id :: !(Maybe J.LanguageKind)+ -- ^ see 'VirtualFile._language_id'+ }+ deriving (Show)++data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile+ deriving (Show)+ data VFS = VFS- { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)+ { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFileEntry) } deriving (Show) data VfsLog- = SplitInsideCodePoint Rope.Position Rope+ = SplitInsideCodePoint Utf16.Position Rope+ | ApplyChangeToClosedFile J.NormalizedUri | URINotFound J.NormalizedUri | Opening J.NormalizedUri | Closing J.NormalizedUri@@ -127,6 +141,7 @@ instance Pretty VfsLog where pretty (SplitInsideCodePoint pos r) = "VFS: asked to make change inside code point. Position" <+> viaShow pos <+> "in" <+> viaShow r+ pretty (ApplyChangeToClosedFile uri) = "VFS: trying to apply a change to a closed file" <+> pretty uri pretty (URINotFound uri) = "VFS: don't know about URI" <+> pretty uri pretty (Opening uri) = "VFS: opening" <+> pretty uri pretty (Closing uri) = "VFS: closing" <+> pretty uri@@ -136,7 +151,9 @@ pretty (DeleteNonExistent uri) = "VFS: asked to delete non-existent file" <+> pretty uri makeFieldsNoPrefix ''VirtualFile+makeFieldsNoPrefix ''ClosedVirtualFile makeFieldsNoPrefix ''VFS+makePrisms ''VirtualFileEntry --- @@ -146,6 +163,22 @@ virtualFileVersion :: VirtualFile -> Int32 virtualFileVersion vf = _lsp_version vf +virtualFileLanguageKind :: VirtualFile -> Maybe J.LanguageKind+virtualFileLanguageKind vf = vf ^. language_id++closedVirtualFileLanguageKind :: ClosedVirtualFile -> Maybe J.LanguageKind+closedVirtualFileLanguageKind vf = vf ^. language_id++virtualFileEntryLanguageKind :: VirtualFileEntry -> Maybe J.LanguageKind+virtualFileEntryLanguageKind (Open vf) = virtualFileLanguageKind vf+virtualFileEntryLanguageKind (Closed vf) = closedVirtualFileLanguageKind vf++toClosedVirtualFile :: VirtualFile -> ClosedVirtualFile+toClosedVirtualFile vf =+ ClosedVirtualFile+ { _language_id = virtualFileLanguageKind vf+ }+ --- emptyVFS :: VFS@@ -156,10 +189,10 @@ -- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS' openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidOpen -> m () openVFS logger msg = do- let J.TextDocumentItem (J.toNormalizedUri -> uri) _ version text = msg ^. J.params . J.textDocument- vfile = VirtualFile version 0 (Rope.fromText text)+ let J.TextDocumentItem (J.toNormalizedUri -> uri) languageId version text = msg ^. J.params . J.textDocument+ vfile = VirtualFile version 0 (Rope.fromText text) (Just languageId) logger <& Opening uri `WithSeverity` Debug- vfsMap . at uri .= Just vfile+ vfsMap . at uri .= (Just $ Open vfile) -- --------------------------------------------------------------------- @@ -172,9 +205,10 @@ J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) version = vid vfs <- get case vfs ^. vfsMap . at uri of- Just (VirtualFile _ file_ver contents) -> do+ Just (Open (VirtualFile _ file_ver contents kind)) -> do contents' <- applyChanges logger contents changes- vfsMap . at uri .= Just (VirtualFile version (file_ver + 1) contents')+ vfsMap . at uri .= Just (Open (VirtualFile version (file_ver + 1) contents' kind))+ Just (Closed (ClosedVirtualFile _)) -> logger <& ApplyChangeToClosedFile uri `WithSeverity` Warning Nothing -> logger <& URINotFound uri `WithSeverity` Warning -- ---------------------------------------------------------------------@@ -185,7 +219,7 @@ %= Map.insertWith (\new old -> if shouldOverwrite then new else old) uri- (VirtualFile 0 0 mempty)+ (Open (VirtualFile 0 0 mempty Nothing)) where shouldOverwrite :: Bool shouldOverwrite = case options of@@ -260,8 +294,8 @@ editRange (J.InL e) = e ^. J.range editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent- editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText- editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText+ editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent $ J.InL $ J.TextDocumentContentChangePartial{_range = e ^. J.range, _rangeLength = Nothing, _text = e ^. J.newText}+ editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent $ J.InL $ J.TextDocumentContentChangePartial{_range = e ^. J.range, _rangeLength = Nothing, _text = e ^. J.newText} applyDocumentChange :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DocumentChange -> m () applyDocumentChange logger (J.InL change) = applyTextDocumentEdit logger change@@ -295,7 +329,7 @@ -- --------------------------------------------------------------------- virtualFileName :: FilePath -> J.NormalizedUri -> VirtualFile -> FilePath-virtualFileName prefix uri (VirtualFile _ file_ver _) =+virtualFileName prefix uri (VirtualFile _ file_ver _ _) = let uri_raw = J.fromNormalizedUri uri basename = maybe "" takeFileName (J.uriToFilePath uri_raw) -- Given a length and a version number, pad the version number to@@ -312,7 +346,8 @@ persistFileVFS logger dir vfs uri = case vfs ^. vfsMap . at uri of Nothing -> Nothing- Just vf ->+ (Just (Closed _)) -> Nothing+ (Just (Open vf)) -> let tfn = virtualFileName dir uri vf action = do exists <- liftIO $ doesFileExist tfn@@ -333,7 +368,12 @@ closeVFS logger msg = do let J.DidCloseTextDocumentParams (J.TextDocumentIdentifier (J.toNormalizedUri -> uri)) = msg ^. J.params logger <& Closing uri `WithSeverity` Debug- vfsMap . at uri .= Nothing+ vfsMap . ix uri+ %= ( \mf ->+ case mf of+ Open f -> Closed $ toClosedVirtualFile f+ Closed f -> Closed f+ ) -- --------------------------------------------------------------------- @@ -348,11 +388,11 @@ applyChange :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> J.TextDocumentContentChangeEvent -> m Rope applyChange logger str (J.TextDocumentContentChangeEvent (J.InL e))- | J.Range (J.Position sl sc) (J.Position fl fc) <- e .! #range- , txt <- e .! #text =- changeChars logger str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt+ | J.Range (J.Position sl sc) (J.Position fl fc) <- e ^. J.range+ , txt <- e ^. J.text =+ changeChars logger str (Utf16.Position (fromIntegral sl) (fromIntegral sc)) (Utf16.Position (fromIntegral fl) (fromIntegral fc)) txt applyChange _ _ (J.TextDocumentContentChangeEvent (J.InR e)) =- pure $ Rope.fromText $ e .! #text+ pure $ Rope.fromText $ e ^. J.text -- --------------------------------------------------------------------- @@ -360,11 +400,11 @@ the given range with the new text. If the given positions lie within a code point then this does nothing (returns the original 'Rope') and logs. -}-changeChars :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> Rope.Position -> Rope.Position -> Text -> m Rope+changeChars :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> Utf16.Position -> Utf16.Position -> Text -> m Rope changeChars logger str start finish new = do- case Rope.splitAtPosition finish str of+ case Rope.utf16SplitAtPosition finish str of Nothing -> logger <& SplitInsideCodePoint finish str `WithSeverity` Warning >> pure str- Just (before, after) -> case Rope.splitAtPosition start before of+ Just (before, after) -> case Rope.utf16SplitAtPosition start before of Nothing -> logger <& SplitInsideCodePoint start before `WithSeverity` Warning >> pure str Just (before', _) -> pure $ mconcat [before', Rope.fromText new, after] @@ -402,11 +442,14 @@ - We then split the line at the given position, and check how long the prefix is, which takes linear time in the length of the (single) line. -We also may need to convert the line back and forth between ropes with different indexing. Again-this is linear time in the length of the line.- So the overall process is logarithmic in the number of lines, and linear in the length of the specific line. Which is okay-ish, so long as we don't have very long lines.++We are not able to use the `Rope.splitAtPosition`+Because when column index out of range or when the column indexing at the newline char.+The prefix result would wrap over the line and having the same result (nextLineNum, 0).+We would not be able to distinguish them. When the first case should return `Nothing`,+second case should return a `Just (CurrentLineNum, columnNumberConverted)`. -} {- | Extracts a specific line from a 'Rope.Rope'.@@ -415,41 +458,12 @@ extractLine :: Rope.Rope -> Word -> Maybe Rope.Rope extractLine rope l = do -- Check for the line being out of bounds- let lastLine = Rope.posLine $ Rope.lengthAsPosition rope+ let lastLine = Utf16.posLine $ Rope.utf16LengthAsPosition rope guard $ l <= lastLine- let (_, suffix) = Rope.splitAtLine l rope (prefix, _) = Rope.splitAtLine 1 suffix pure prefix -{- | Translate a code-point offset into a code-unit offset.- Linear in the length of the rope.--}-codePointOffsetToCodeUnitOffset :: URope.Rope -> Word -> Maybe Word-codePointOffsetToCodeUnitOffset rope offset = do- -- Check for the position being out of bounds- guard $ offset <= URope.length rope- -- Split at the given position in *code points*- let (prefix, _) = URope.splitAt offset rope- -- Convert the prefix to a rope using *code units*- utf16Prefix = Rope.fromText $ URope.toText prefix- -- Get the length of the prefix in *code units*- pure $ Rope.length utf16Prefix--{- | Translate a UTF-16 code-unit offset into a code-point offset.- Linear in the length of the rope.--}-codeUnitOffsetToCodePointOffset :: Rope.Rope -> Word -> Maybe Word-codeUnitOffsetToCodePointOffset rope offset = do- -- Check for the position being out of bounds- guard $ offset <= Rope.length rope- -- Split at the given position in *code units*- (prefix, _) <- Rope.splitAt offset rope- -- Convert the prefix to a rope using *code points*- let utfPrefix = URope.fromText $ Rope.toText prefix- -- Get the length of the prefix in *code points*- pure $ URope.length utfPrefix- {- | Given a virtual file, translate a 'CodePointPosition' in that file into a 'J.Position' in that file. Will return 'Nothing' if the requested position is out of bounds of the document.@@ -458,15 +472,12 @@ the position. -} codePointPositionToPosition :: VirtualFile -> CodePointPosition -> Maybe J.Position-codePointPositionToPosition vFile (CodePointPosition l cpc) = do+codePointPositionToPosition vFile (CodePointPosition l c) = do -- See Note [Converting between code points and code units] let text = _file_text vFile- utf16Line <- extractLine text (fromIntegral l)- -- Convert the line a rope using *code points*- let utfLine = URope.fromText $ Rope.toText utf16Line-- cuc <- codePointOffsetToCodeUnitOffset utfLine (fromIntegral cpc)- pure $ J.Position l (fromIntegral cuc)+ lineRope <- extractLine text $ fromIntegral l+ guard $ c <= fromIntegral (Rope.charLength lineRope)+ return $ J.Position l (fromIntegral $ Rope.utf16Length $ fst $ Rope.charSplitAt (fromIntegral c) lineRope) {- | Given a virtual file, translate a 'CodePointRange' in that file into a 'J.Range' in that file. @@ -487,13 +498,12 @@ the position. -} positionToCodePointPosition :: VirtualFile -> J.Position -> Maybe CodePointPosition-positionToCodePointPosition vFile (J.Position l cuc) = do+positionToCodePointPosition vFile (J.Position l c) = do -- See Note [Converting between code points and code units] let text = _file_text vFile- utf16Line <- extractLine text (fromIntegral l)-- cpc <- codeUnitOffsetToCodePointOffset utf16Line (fromIntegral cuc)- pure $ CodePointPosition l (fromIntegral cpc)+ lineRope <- extractLine text $ fromIntegral l+ guard $ c <= fromIntegral (Rope.utf16Length lineRope)+ CodePointPosition l . fromIntegral . Rope.charLength . fst <$> Rope.utf16SplitAt (fromIntegral c) lineRope {- | Given a virtual file, translate a 'J.Range' in that file into a 'CodePointRange' in that file. @@ -506,64 +516,9 @@ rangeToCodePointRange vFile (J.Range b e) = CodePointRange <$> positionToCodePointPosition vFile b <*> positionToCodePointPosition vFile e --- ------------------------------------------------------------------------- TODO:AZ:move this to somewhere sane---- | Describes the line at the current cursor position-data PosPrefixInfo = PosPrefixInfo- { fullLine :: !T.Text- -- ^ The full contents of the line the cursor is at- , prefixModule :: !T.Text- -- ^ If any, the module name that was typed right before the cursor position.- -- For example, if the user has typed "Data.Maybe.from", then this property- -- will be "Data.Maybe"- , prefixText :: !T.Text- -- ^ The word right before the cursor position, after removing the module part.- -- For example if the user has typed "Data.Maybe.from",- -- then this property will be "from"- , cursorPos :: !J.Position- -- ^ The cursor position- }- deriving (Show, Eq)--getCompletionPrefix :: (Monad m) => J.Position -> VirtualFile -> m (Maybe PosPrefixInfo)-getCompletionPrefix pos@(J.Position l c) (VirtualFile _ _ ropetext) =- return $ Just $ fromMaybe (PosPrefixInfo "" "" "" pos) $ do- -- Maybe monad- let lastMaybe [] = Nothing- lastMaybe xs = Just $ last xs-- let curRope = fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (fromIntegral l) ropetext- beforePos <- Rope.toText . fst <$> Rope.splitAt (fromIntegral c) curRope- curWord <-- if- | T.null beforePos -> Just ""- | T.last beforePos == ' ' -> Just "" -- don't count abc as the curword in 'abc '- | otherwise -> lastMaybe (T.words beforePos)-- let parts =- T.split (== '.') $- T.takeWhileEnd (\x -> isAlphaNum x || x `elem` ("._'" :: String)) curWord- case reverse parts of- [] -> Nothing- (x : xs) -> do- let modParts =- dropWhile (not . isUpper . T.head) $- reverse $- filter (not . T.null) xs- modName = T.intercalate "." modParts- -- curRope is already a single line, but it may include an enclosing '\n'- let curLine = T.dropWhileEnd (== '\n') $ Rope.toText curRope- return $ PosPrefixInfo curLine modName x pos---- ---------------------------------------------------------------------- rangeLinesFromVfs :: VirtualFile -> J.Range -> T.Text-rangeLinesFromVfs (VirtualFile _ _ ropetext) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r+rangeLinesFromVfs (VirtualFile _ _ ropetext _) (J.Range (J.Position lf _cf) (J.Position lt _ct)) = r where (_, s1) = Rope.splitAtLine (fromIntegral lf) ropetext (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1 r = Rope.toText s2---- ---------------------------------------------------------------------
test/VspSpec.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} module VspSpec where -import Data.Row import Data.String import Data.Text qualified as T-import Data.Text.Utf16.Rope qualified as Rope+import Data.Text.Utf16.Rope.Mixed qualified as Rope import Language.LSP.Protocol.Types qualified as J import Language.LSP.VFS @@ -30,12 +29,12 @@ -- --------------------------------------------------------------------- vfsFromText :: T.Text -> VirtualFile-vfsFromText text = VirtualFile 0 0 (Rope.fromText text)+vfsFromText text = VirtualFile 0 0 (Rope.fromText text) $ Just J.LanguageKind_Haskell -- --------------------------------------------------------------------- mkChangeEvent :: J.Range -> T.Text -> J.TextDocumentContentChangeEvent-mkChangeEvent r t = J.TextDocumentContentChangeEvent $ J.InL $ #range .== r .+ #rangeLength .== Nothing .+ #text .== t+mkChangeEvent r t = J.TextDocumentContentChangeEvent $ J.InL $ J.TextDocumentContentChangePartial{J._range = r, J._rangeLength = Nothing, J._text = t} vspSpec :: Spec vspSpec = do@@ -244,7 +243,7 @@ [ "a𐐀b" , "a𐐀b" ]- vfile = VirtualFile 0 0 (fromString orig)+ vfile = VirtualFile 0 0 (fromString orig) $ Just J.LanguageKind_Haskell positionToCodePointPosition vfile (J.Position 1 0) `shouldBe` Just (CodePointPosition 1 0) positionToCodePointPosition vfile (J.Position 1 1) `shouldBe` Just (CodePointPosition 1 1)@@ -266,7 +265,7 @@ [ "a𐐀b" , "a𐐀b" ]- vfile = VirtualFile 0 0 (fromString orig)+ vfile = VirtualFile 0 0 (fromString orig) $ Just J.LanguageKind_Haskell codePointPositionToPosition vfile (CodePointPosition 1 0) `shouldBe` Just (J.Position 1 0) codePointPositionToPosition vfile (CodePointPosition 1 1) `shouldBe` Just (J.Position 1 1)@@ -278,27 +277,3 @@ codePointPositionToPosition vfile (CodePointPosition 2 1) `shouldBe` Nothing -- Greater line than max line codePointPositionToPosition vfile (CodePointPosition 3 0) `shouldBe` Nothing-- -- ----------------------------------- it "getCompletionPrefix" $ do- let- orig =- T.unlines- [ "{-# ings #-}"- , "import Data.List"- ]- pp4 <- getCompletionPrefix (J.Position 0 4) (vfsFromText orig)- pp4 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 4))-- pp5 <- getCompletionPrefix (J.Position 0 5) (vfsFromText orig)- pp5 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "i" (J.Position 0 5))-- pp6 <- getCompletionPrefix (J.Position 0 6) (vfsFromText orig)- pp6 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "in" (J.Position 0 6))-- pp14 <- getCompletionPrefix (J.Position 1 14) (vfsFromText orig)- pp14 `shouldBe` Just (PosPrefixInfo "import Data.List" "Data" "Li" (J.Position 1 14))-- pp00 <- getCompletionPrefix (J.Position 0 0) (vfsFromText orig)- pp00 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 0))