diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 } diff --git a/example/Reactor.hs b/example/Reactor.hs --- a/example/Reactor.hs +++ b/example/Reactor.hs @@ -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) diff --git a/example/Simple.hs b/example/Simple.hs --- a/example/Simple.hs +++ b/example/Simple.hs @@ -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 diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -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 diff --git a/src/Language/LSP/Diagnostics.hs b/src/Language/LSP/Diagnostics.hs --- a/src/Language/LSP/Diagnostics.hs +++ b/src/Language/LSP/Diagnostics.hs @@ -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 -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Server.hs b/src/Language/LSP/Server.hs --- a/src/Language/LSP/Server.hs +++ b/src/Language/LSP/Server.hs @@ -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 diff --git a/src/Language/LSP/Server/Control.hs b/src/Language/LSP/Server/Control.hs --- a/src/Language/LSP/Server/Control.hs +++ b/src/Language/LSP/Server/Control.hs @@ -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" diff --git a/src/Language/LSP/Server/Core.hs b/src/Language/LSP/Server/Core.hs --- a/src/Language/LSP/Server/Core.hs +++ b/src/Language/LSP/Server/Core.hs @@ -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`. -} diff --git a/src/Language/LSP/Server/Processing.hs b/src/Language/LSP/Server/Processing.hs --- a/src/Language/LSP/Server/Processing.hs +++ b/src/Language/LSP/Server/Processing.hs @@ -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 diff --git a/src/Language/LSP/Server/Progress.hs b/src/Language/LSP/Server/Progress.hs new file mode 100644 --- /dev/null +++ b/src/Language/LSP/Server/Progress.hs @@ -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)))) diff --git a/src/Language/LSP/VFS.hs b/src/Language/LSP/VFS.hs --- a/src/Language/LSP/VFS.hs +++ b/src/Language/LSP/VFS.hs @@ -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 - --- --------------------------------------------------------------------- diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -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))