diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,85 @@ # 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). +- VFS no longer requires IO to initialize, functions that wrote to a temporary directory + now take the directory as an argument. + +## 2.2.0.0 + +- Many changes relating to client configuration + - `lsp` now sends `workspace/configuration` requests in response to `intialized` and + `workspace/didChangeConfiguration` requests. It still attempts to parse configuration + from `intializationOptions` and `workspace/didChangeConfiguration` as a fallback. + - Servers must provide a configuration section for use in `workspace/configuration`. + - `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 + 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. + 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. + +## 2.0.0.0 + +* Support `lsp-types-2.0.0.0`. + ## 1.6.0.0 * Pinned to lsp-types 1.6 @@ -168,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,16 +1,9 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} - --- So we can keep using the old prettyprinter modules (which have a better --- compatibility range) for now. -{-# OPTIONS_GHC -Wno-deprecations #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {- | This is an example language server built with haskell-lsp using a 'Reactor' @@ -28,34 +21,35 @@ -} module Main (main) where -import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) -import qualified Colog.Core as L -import Control.Concurrent.STM.TChan -import qualified Control.Exception as E -import Control.Lens hiding (Iso) -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.STM -import qualified Data.Aeson as J -import Data.Int (Int32) -import qualified Data.Text as T -import Data.Text.Prettyprint.Doc -import GHC.Generics (Generic) -import Language.LSP.Server -import System.IO -import Language.LSP.Diagnostics -import Language.LSP.Logging (defaultClientLogger) -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as J -import Language.LSP.VFS -import System.Exit -import Control.Concurrent - +import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) +import Colog.Core qualified as L +import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Exception qualified as E +import Control.Lens hiding (Iso) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.STM +import Data.Aeson qualified as J +import Data.Int (Int32) +import Data.Text qualified as T +import GHC.Generics (Generic) +import Language.LSP.Diagnostics +import Language.LSP.Logging (defaultClientLogger) +import Language.LSP.Protocol.Lens qualified as LSP +import Language.LSP.Protocol.Message qualified as LSP +import Language.LSP.Protocol.Types qualified as LSP +import Language.LSP.Server +import Language.LSP.VFS +import Prettyprinter +import System.Exit +import System.IO -- --------------------------------------------------------------------- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} {-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + -- --------------------------------------------------------------------- -- @@ -67,13 +61,12 @@ -- --------------------------------------------------------------------- -data Config = Config { fooTheBar :: Bool, wibbleFactor :: Int } +data Config = Config {fooTheBar :: Bool, wibbleFactor :: Int} deriving (Generic, J.ToJSON, J.FromJSON, Show) run :: IO Int run = flip E.catches handlers $ do - - rin <- atomically newTChan :: IO (TChan ReactorInput) + rin <- atomically newTChan :: IO (TChan ReactorInput) let -- Three loggers: @@ -87,52 +80,57 @@ dualLogger :: LogAction (LspM Config) (WithSeverity T.Text) dualLogger = clientLogger <> L.hoistLogAction liftIO stderrLogger - serverDefinition = ServerDefinition - { defaultConfig = Config {fooTheBar = False, wibbleFactor = 0 } - , onConfigurationChange = \_old v -> do - case J.fromJSON v of - J.Error e -> Left (T.pack e) - J.Success cfg -> Right cfg - , doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env) - -- Handlers log to both the client and stderr - , staticHandlers = lspHandlers dualLogger rin - , interpretHandler = \env -> Iso (runLspT env) liftIO - , options = lspOptions - } + serverDefinition = + ServerDefinition + { defaultConfig = Config{fooTheBar = False, wibbleFactor = 0} + , parseConfig = \_old v -> do + case J.fromJSON v of + J.Error e -> Left (T.pack e) + J.Success cfg -> Right cfg + , onConfigChange = const $ pure () + , configSection = "demo" + , doInitialize = \env _ -> forkIO (reactor stderrLogger rin) >> pure (Right env) + , -- Handlers log to both the client and stderr + staticHandlers = \_caps -> lspHandlers dualLogger rin + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = lspOptions + } let logToText = T.pack . show . pretty runServerWithHandles - -- Log to both the client and stderr when we can, stderr beforehand + -- Log to both the client and stderr when we can, stderr beforehand (L.cmap (fmap logToText) stderrLogger) (L.cmap (fmap logToText) dualLogger) stdin stdout serverDefinition - - where - handlers = [ E.Handler ioExcept - , E.Handler someExcept - ] - ioExcept (e :: E.IOException) = print e >> return 1 - someExcept (e :: E.SomeException) = print e >> return 1 + where + handlers = + [ E.Handler ioExcept + , E.Handler someExcept + ] + ioExcept (e :: E.IOException) = print e >> return 1 + someExcept (e :: E.SomeException) = print e >> return 1 -- --------------------------------------------------------------------- -syncOptions :: J.TextDocumentSyncOptions -syncOptions = J.TextDocumentSyncOptions - { J._openClose = Just True - , J._change = Just J.TdSyncIncremental - , J._willSave = Just False - , J._willSaveWaitUntil = Just False - , J._save = Just $ J.InR $ J.SaveOptions $ Just False - } +syncOptions :: LSP.TextDocumentSyncOptions +syncOptions = + LSP.TextDocumentSyncOptions + { LSP._openClose = Just True + , LSP._change = Just LSP.TextDocumentSyncKind_Incremental + , LSP._willSave = Just False + , LSP._willSaveWaitUntil = Just False + , LSP._save = Just $ LSP.InR $ LSP.SaveOptions $ Just False + } lspOptions :: Options -lspOptions = defaultOptions - { textDocumentSync = Just syncOptions - , executeCommandCommands = Just ["lsp-hello-command"] - } +lspOptions = + defaultOptions + { optTextDocumentSync = Just syncOptions + , optExecuteCommandCommands = Just ["lsp-hello-command"] + } -- --------------------------------------------------------------------- @@ -143,27 +141,32 @@ newtype ReactorInput = ReactorAction (IO ()) --- | Analyze the file and send any diagnostics to the client in a --- "textDocument/publishDiagnostics" notification -sendDiagnostics :: J.NormalizedUri -> Maybe Int32 -> LspM Config () +{- | Analyze the file and send any diagnostics to the client in a + "textDocument/publishDiagnostics" notification +-} +sendDiagnostics :: LSP.NormalizedUri -> Maybe Int32 -> LspM Config () sendDiagnostics fileUri version = do let - diags = [J.Diagnostic - (J.Range (J.Position 0 1) (J.Position 0 5)) - (Just J.DsWarning) -- severity - Nothing -- code - (Just "lsp-hello") -- source - "Example diagnostic message" - Nothing -- tags - (Just (J.List [])) - ] + diags = + [ LSP.Diagnostic + (LSP.Range (LSP.Position 0 1) (LSP.Position 0 5)) + (Just LSP.DiagnosticSeverity_Warning) -- severity + Nothing -- code + Nothing + (Just "lsp-hello") -- source + "Example diagnostic message" + Nothing -- tags + (Just []) + Nothing + ] publishDiagnostics 100 fileUri version (partitionBySource diags) -- --------------------------------------------------------------------- --- | The single point that all events flow through, allowing management of state --- to stitch replies and requests together from the two asynchronous sides: lsp --- server and backend compiler +{- | The single point that all events flow through, allowing management of state + to stitch replies and requests together from the two asynchronous sides: lsp + server and backend compiler +-} reactor :: L.LogAction IO (WithSeverity T.Text) -> TChan ReactorInput -> IO () reactor logger inp = do logger <& "Started the reactor" `WithSeverity` Info @@ -171,144 +174,148 @@ ReactorAction act <- atomically $ readTChan inp act --- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as --- input into the reactor +{- | Check if we have a handler, and if we create a haskell-lsp handler to pass it as + input into the reactor +-} lspHandlers :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> TChan ReactorInput -> Handlers m lspHandlers logger rin = mapHandlers goReq goNot (handle logger) - where - goReq :: forall (a :: J.Method J.FromClient J.Request). Handler (LspM Config) a -> Handler (LspM Config) a - goReq f = \msg k -> do - env <- getLspEnv - liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k) + where + goReq :: forall (a :: LSP.Method LSP.ClientToServer LSP.Request). Handler (LspM Config) a -> Handler (LspM Config) a + goReq f = \msg k -> do + env <- getLspEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg k) - goNot :: forall (a :: J.Method J.FromClient J.Notification). Handler (LspM Config) a -> Handler (LspM Config) a - goNot f = \msg -> do - env <- getLspEnv - liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg) + goNot :: forall (a :: LSP.Method LSP.ClientToServer LSP.Notification). Handler (LspM Config) a -> Handler (LspM Config) a + goNot f = \msg -> do + env <- getLspEnv + liftIO $ atomically $ writeTChan rin $ ReactorAction (runLspT env $ f msg) -- | Where the actual logic resides for handling requests and notifications. handle :: (m ~ LspM Config) => L.LogAction m (WithSeverity T.Text) -> Handlers m -handle logger = mconcat - [ notificationHandler J.SInitialized $ \_msg -> do - logger <& "Processing the Initialized notification" `WithSeverity` Info - - -- We're initialized! Lets send a showMessageRequest now - let params = J.ShowMessageRequestParams - J.MtWarning - "What's your favourite language extension?" - (Just [J.MessageActionItem "Rank2Types", J.MessageActionItem "NPlusKPatterns"]) - - void $ sendRequest J.SWindowShowMessageRequest params $ \res -> - case res of - Left e -> logger <& ("Got an error: " <> T.pack (show e)) `WithSeverity` Error - Right _ -> do - sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Excellent choice") - - -- We can dynamically register a capability once the user accepts it - sendNotification J.SWindowShowMessage (J.ShowMessageParams J.MtInfo "Turning on code lenses dynamically") - - let regOpts = J.CodeLensRegistrationOptions Nothing Nothing (Just False) - - void $ registerCapability J.STextDocumentCodeLens regOpts $ \_req responder -> do - logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info - let cmd = J.Command "Say hello" "lsp-hello-command" Nothing - rsp = J.List [J.CodeLens (J.mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right rsp) - - , notificationHandler J.STextDocumentDidOpen $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - fileName = J.uriToFilePath doc - logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info - sendDiagnostics (J.toNormalizedUri doc) (Just 0) - - , notificationHandler J.SWorkspaceDidChangeConfiguration $ \msg -> do - cfg <- getConfig - logger L.<& ("Configuration changed: " <> T.pack (show (msg,cfg))) `WithSeverity` Info - sendNotification J.SWindowShowMessage $ - J.ShowMessageParams J.MtInfo $ "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) - - , notificationHandler J.STextDocumentDidChange $ \msg -> do - let doc = msg ^. J.params - . J.textDocument - . J.uri - . to J.toNormalizedUri - logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info - mdoc <- getVirtualFile doc - case mdoc of - 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 +handle logger = + mconcat + [ notificationHandler LSP.SMethod_Initialized $ \_msg -> do + logger <& "Processing the Initialized notification" `WithSeverity` Info - , notificationHandler J.STextDocumentDidSave $ \msg -> do - let doc = msg ^. J.params . J.textDocument . J.uri - fileName = J.uriToFilePath doc - logger <& ("Processing DidSaveTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info - sendDiagnostics (J.toNormalizedUri doc) Nothing + -- We're initialized! Lets send a showMessageRequest now + let params = + LSP.ShowMessageRequestParams + LSP.MessageType_Warning + "What's your favourite language extension?" + (Just [LSP.MessageActionItem "Rank2Types", LSP.MessageActionItem "NPlusKPatterns"]) - , requestHandler J.STextDocumentRename $ \req responder -> do - logger <& "Processing a textDocument/rename request" `WithSeverity` Info - let params = req ^. J.params - J.Position l c = params ^. J.position - newName = params ^. J.newName - vdoc <- getVersionedTextDoc (params ^. J.textDocument) - -- Replace some text at the position with what the user entered - let edit = J.InL $ J.TextEdit (J.mkRange l c l (c + fromIntegral (T.length newName))) newName - tde = J.TextDocumentEdit vdoc (J.List [edit]) - -- "documentChanges" field is preferred over "changes" - rsp = J.WorkspaceEdit Nothing (Just (J.List [J.InL tde])) Nothing - responder (Right rsp) + void $ sendRequest LSP.SMethod_WindowShowMessageRequest params $ \res -> + case res of + Left e -> logger <& ("Got an error: " <> T.pack (show e)) `WithSeverity` Error + Right _ -> do + sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Excellent choice") - , requestHandler J.STextDocumentHover $ \req responder -> do - logger <& "Processing a textDocument/hover request" `WithSeverity` Info - let J.HoverParams _doc pos _workDone = req ^. J.params - J.Position _l _c' = pos - rsp = J.Hover ms (Just range) - ms = J.HoverContents $ J.markedUpContent "lsp-hello" "Your type info here!" - range = J.Range pos pos - responder (Right $ Just rsp) + -- We can dynamically register a capability once the user accepts it + sendNotification LSP.SMethod_WindowShowMessage (LSP.ShowMessageParams LSP.MessageType_Info "Turning on code lenses dynamically") - , requestHandler J.STextDocumentDocumentSymbol $ \req responder -> do - logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info - let J.DocumentSymbolParams _ _ doc = req ^. J.params - loc = J.Location (doc ^. J.uri) (J.Range (J.Position 0 0) (J.Position 0 0)) - sym = J.SymbolInformation "lsp-hello" J.SkFunction Nothing Nothing loc Nothing - rsp = J.InR (J.List [sym]) - responder (Right rsp) + let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False) - , requestHandler J.STextDocumentCodeAction $ \req responder -> do - logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info - let params = req ^. J.params - doc = params ^. J.textDocument - (J.List diags) = params ^. J.context . J.diagnostics - -- makeCommand only generates commands for diagnostics whose source is us - makeCommand (J.Diagnostic (J.Range s _) _s _c (Just "lsp-hello") _m _t _l) = [J.Command title cmd cmdparams] - where - title = "Apply LSP hello command:" <> head (T.lines _m) - -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above - cmd = "lsp-hello-command" - -- need 'file' and 'start_pos' - args = J.List - [ J.object [("file", J.object [("textDocument",J.toJSON doc)])] - , J.object [("start_pos",J.object [("position", J.toJSON s)])] + 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 + logger <& ("Processing DidOpenTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info + sendDiagnostics (LSP.toNormalizedUri doc) (Just 0) + , notificationHandler LSP.SMethod_WorkspaceDidChangeConfiguration $ \msg -> do + cfg <- getConfig + logger L.<& ("Configuration changed: " <> T.pack (show (msg, cfg))) `WithSeverity` Info + sendNotification LSP.SMethod_WindowShowMessage $ + LSP.ShowMessageParams LSP.MessageType_Info $ + "Wibble factor set to " <> T.pack (show (wibbleFactor cfg)) + , notificationHandler LSP.SMethod_TextDocumentDidChange $ \msg -> do + let doc = + msg + ^. LSP.params + . LSP.textDocument + . LSP.uri + . to LSP.toNormalizedUri + logger <& ("Processing DidChangeTextDocument for: " <> T.pack (show doc)) `WithSeverity` Info + mdoc <- getVirtualFile doc + case mdoc of + 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 + , notificationHandler LSP.SMethod_TextDocumentDidSave $ \msg -> do + let doc = msg ^. LSP.params . LSP.textDocument . LSP.uri + fileName = LSP.uriToFilePath doc + logger <& ("Processing DidSaveTextDocument for: " <> T.pack (show fileName)) `WithSeverity` Info + sendDiagnostics (LSP.toNormalizedUri doc) Nothing + , requestHandler LSP.SMethod_TextDocumentRename $ \req responder -> do + logger <& "Processing a textDocument/rename request" `WithSeverity` Info + let params = req ^. LSP.params + LSP.Position l c = params ^. LSP.position + newName = params ^. LSP.newName + vdoc <- getVersionedTextDoc (params ^. LSP.textDocument) + -- Replace some text at the position with what the user entered + let edit = LSP.InL $ LSP.TextEdit (LSP.mkRange l c l (c + fromIntegral (T.length newName))) newName + tde = LSP.TextDocumentEdit (LSP._versionedTextDocumentIdentifier # vdoc) [edit] + -- "documentChanges" field is preferred over "changes" + rsp = LSP.WorkspaceEdit Nothing (Just [LSP.InL tde]) Nothing + responder (Right $ LSP.InL rsp) + , requestHandler LSP.SMethod_TextDocumentHover $ \req responder -> do + logger <& "Processing a textDocument/hover request" `WithSeverity` Info + let LSP.HoverParams _doc pos _workDone = req ^. LSP.params + LSP.Position _l _c' = pos + rsp = LSP.Hover ms (Just range) + ms = LSP.InL $ LSP.mkMarkdown "Your type info here!" + range = LSP.Range pos pos + responder (Right $ LSP.InL rsp) + , requestHandler LSP.SMethod_TextDocumentDocumentSymbol $ \req responder -> do + logger <& "Processing a textDocument/documentSymbol request" `WithSeverity` Info + let LSP.DocumentSymbolParams _ _ doc = req ^. LSP.params + loc = LSP.Location (doc ^. LSP.uri) (LSP.Range (LSP.Position 0 0) (LSP.Position 0 0)) + rsp = [LSP.SymbolInformation "lsp-hello" LSP.SymbolKind_Function Nothing Nothing Nothing loc] + responder (Right $ LSP.InL rsp) + , requestHandler LSP.SMethod_TextDocumentCodeAction $ \req responder -> do + logger <& "Processing a textDocument/codeAction request" `WithSeverity` Info + let params = req ^. LSP.params + doc = params ^. LSP.textDocument + diags = params ^. LSP.context . LSP.diagnostics + -- makeCommand only generates commands for diagnostics whose source is us + makeCommand d + | (LSP.Range s _) <- d ^. LSP.range + , (Just "lsp-hello") <- d ^. LSP.source = + let + title = "Apply LSP hello command:" <> head (T.lines $ d ^. LSP.message) + -- NOTE: the cmd needs to be registered via the InitializeResponse message. See lspOptions above + cmd = "lsp-hello-command" + -- need 'file' and 'start_pos' + args = + [ J.object [("file", J.object [("textDocument", J.toJSON doc)])] + , J.object [("start_pos", J.object [("position", J.toJSON s)])] ] - cmdparams = Just args - makeCommand (J.Diagnostic _r _s _c _source _m _t _l) = [] - rsp = J.List $ map J.InL $ concatMap makeCommand diags - responder (Right rsp) - - , requestHandler J.SWorkspaceExecuteCommand $ \req responder -> do - logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info - let params = req ^. J.params - margs = params ^. J.arguments - - logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug - responder (Right (J.Object mempty)) -- respond to the request + cmdparams = Just args + in + [LSP.Command title cmd cmdparams] + makeCommand _ = [] + rsp = map LSP.InL $ concatMap makeCommand diags + responder (Right $ LSP.InL rsp) + , requestHandler LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do + logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info + let params = req ^. LSP.params + margs = params ^. LSP.arguments - void $ withProgress "Executing some long running command" Cancellable $ \update -> - forM [(0 :: J.UInt)..10] $ \i -> do - update (ProgressAmount (Just (i * 10)) (Just "Doing stuff")) - liftIO $ threadDelay (1 * 1000000) - ] + 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" (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 @@ -1,45 +1,55 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} -import Language.LSP.Server -import Language.LSP.Types import Control.Monad.IO.Class -import qualified Data.Text as T +import Data.Text qualified as T +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server handlers :: Handlers (LspM ()) -handlers = mconcat - [ notificationHandler SInitialized $ \_not -> do - let params = ShowMessageRequestParams MtInfo "Turn on code lenses?" - (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) - _ <- sendRequest SWindowShowMessageRequest params $ \case - Right (Just (MessageActionItem "Turn on")) -> do - let regOpts = CodeLensRegistrationOptions Nothing Nothing (Just False) - - _ <- registerCapability STextDocumentCodeLens regOpts $ \_req responder -> do +handlers = + mconcat + [ notificationHandler SMethod_Initialized $ \_not -> do + let params = + ShowMessageRequestParams + MessageType_Info + "Turn on code lenses?" + (Just [MessageActionItem "Turn on", MessageActionItem "Don't"]) + _ <- sendRequest SMethod_WindowShowMessageRequest params $ \case + Right (InL (MessageActionItem "Turn on")) -> do + let regOpts = CodeLensRegistrationOptions (InR Null) Nothing (Just False) + + _ <- registerCapability mempty SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do let cmd = Command "Say hello" "lsp-hello-command" Nothing - rsp = List [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] - responder (Right rsp) + rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing] + responder $ Right $ InL rsp pure () Right _ -> - sendNotification SWindowShowMessage (ShowMessageParams MtInfo "Not turning on code lenses") + sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "Not turning on code lenses") Left err -> - sendNotification SWindowShowMessage (ShowMessageParams MtError $ "Something went wrong!\n" <> T.pack (show err)) - pure () - , requestHandler STextDocumentHover $ \req responder -> do - let RequestMessage _ _ _ (HoverParams _doc pos _workDone) = req - Position _l _c' = pos - rsp = Hover ms (Just range) - ms = HoverContents $ markedUpContent "lsp-demo-simple-server" "Hello world" - range = Range pos pos - responder (Right $ Just rsp) - ] + sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Error $ "Something went wrong!\n" <> T.pack (show err)) + pure () + , requestHandler SMethod_TextDocumentHover $ \req responder -> do + let TRequestMessage _ _ _ (HoverParams _doc pos _workDone) = req + Position _l _c' = pos + rsp = Hover (InL ms) (Just range) + ms = mkMarkdown "Hello world" + range = Range pos pos + responder (Right $ InL rsp) + ] main :: IO Int -main = runServer $ ServerDefinition - { onConfigurationChange = const $ const $ Right () - , defaultConfig = () - , doInitialize = \env _req -> pure $ Right env - , staticHandlers = handlers - , interpretHandler = \env -> Iso (runLspT env) liftIO - , options = defaultOptions - } +main = + runServer $ + ServerDefinition + { parseConfig = const $ const $ Right () + , onConfigChange = const $ pure () + , defaultConfig = () + , configSection = "demo" + , doInitialize = \env _req -> pure $ Right env + , staticHandlers = \_caps -> handlers + , interpretHandler = \env -> Iso (runLspT env) liftIO + , options = defaultOptions + } diff --git a/lsp.cabal b/lsp.cabal --- a/lsp.cabal +++ b/lsp.cabal @@ -1,122 +1,143 @@ -cabal-version: 2.2 -name: lsp -version: 1.6.0.0 -synopsis: Haskell library for the Microsoft Language Server Protocol +cabal-version: 2.2 +name: lsp +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 + allow language implementors to support the Language Server + Protocol for their specific language. + . + An example of this is for Haskell via the Haskell Language + Server, at https://github.com/haskell/haskell-language-server -description: An implementation of the types, and basic message server to - allow language implementors to support the Language Server - Protocol for their specific language. - . - An example of this is for Haskell via the Haskell Language - Server, at https://github.com/haskell/haskell-language-server +homepage: https://github.com/haskell/lsp +license: MIT +license-file: LICENSE +author: Alan Zimmerman +maintainer: alan.zimm@gmail.com +copyright: Alan Zimmerman, 2016-2021 +category: Development +build-type: Simple +extra-doc-files: + ChangeLog.md + README.md -homepage: https://github.com/haskell/lsp -license: MIT -license-file: LICENSE -author: Alan Zimmerman -maintainer: alan.zimm@gmail.com -copyright: Alan Zimmerman, 2016-2021 -category: Development -build-type: Simple -extra-source-files: ChangeLog.md, README.md +source-repository head + type: git + location: https://github.com/haskell/lsp +common warnings + ghc-options: -Wall -Wunused-packages -Wno-unticked-promoted-constructors + library - reexported-modules: Language.LSP.Types - , Language.LSP.Types.Capabilities - , Language.LSP.Types.Lens - exposed-modules: Language.LSP.Server - , Language.LSP.Diagnostics - , Language.LSP.Logging - , Language.LSP.VFS - other-modules: Language.LSP.Server.Core - , Language.LSP.Server.Control - , Language.LSP.Server.Processing - ghc-options: -Wall - build-depends: base >= 4.11 && < 5 - , async >= 2.0 - , aeson >=1.0.0.0 - , attoparsec - , bytestring - , containers - , co-log-core >= 0.3.1.0 - , data-default - , directory - , exceptions - , filepath - , hashable - , lsp-types == 1.6.* - , lens >= 4.15.2 - , mtl < 2.4 - , prettyprinter - , sorted-list == 0.2.1.* - , stm == 2.5.* - , temporary - , text - , text-rope - , transformers >= 0.5.6 && < 0.7 - , unordered-containers - , unliftio-core >= 0.2.0.0 - -- used for generating random uuids for dynamic registration - , random - , uuid >= 1.3 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -fprint-explicit-kinds + import: warnings + hs-source-dirs: src + default-language: GHC2021 + ghc-options: -fprint-explicit-kinds + reexported-modules: + , Language.LSP.Protocol.Types + , Language.LSP.Protocol.Lens + , Language.LSP.Protocol.Capabilities + , Language.LSP.Protocol.Message + exposed-modules: + Language.LSP.Diagnostics + Language.LSP.Logging + Language.LSP.Server + Language.LSP.VFS + + other-modules: + Language.LSP.Server.Control + Language.LSP.Server.Core + Language.LSP.Server.Processing + Language.LSP.Server.Progress + + build-depends: + , 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 >=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 - 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 + , lsp + , prettyprinter + , stm + , text - build-depends: base - , aeson - , co-log-core - , lens >= 4.15.2 - , stm - , prettyprinter - , text - -- the package library. Comment this out if you want repl changes to propagate - , lsp + -- the package library. Comment this out if you want repl changes to propagate if !flag(demo) - buildable: False + buildable: False executable lsp-demo-simple-server - main-is: Simple.hs - hs-source-dirs: example - default-language: Haskell2010 - ghc-options: -Wall -Wno-unticked-promoted-constructors - build-depends: base - -- the package library. Comment this out if you want repl changes to propagate - , lsp - , text + import: warnings + main-is: Simple.hs + hs-source-dirs: example + default-language: GHC2021 + build-depends: + , base + , lsp + , text + + -- the package library. Comment this out if you want repl changes to propagate if !flag(demo) - buildable: False + buildable: False flag demo description: Build the demo executables default: False - test-suite lsp-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Main.hs - other-modules: Spec - DiagnosticsSpec - VspSpec - build-depends: base - , containers - , lsp - , hspec - , sorted-list == 0.2.1.* - , text - , text-rope - , unordered-containers - build-tool-depends: hspec-discover:hspec-discover - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - default-language: Haskell2010 + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + DiagnosticsSpec + Spec + VspSpec -source-repository head - type: git - location: https://github.com/haskell/lsp + build-depends: + , base + , containers + , hspec + , lsp + , sorted-list + , text + , text-rope + , unordered-containers + + build-tool-depends: hspec-discover:hspec-discover + 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,89 +1,101 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {- Manage the "textDocument/publishDiagnostics" notifications to keep a local copy of the diagnostics for a particular file and version, partitioned by source. -} -module Language.LSP.Diagnostics - ( - DiagnosticStore - , DiagnosticsBySource - , StoreItem(..) - , partitionBySource - , flushBySource - , updateDiagnostics - , getDiagnosticParamsFor +module Language.LSP.Diagnostics ( + DiagnosticStore, + DiagnosticsBySource, + StoreItem (..), + partitionBySource, + flushBySource, + flushBySourceAndUri, + updateDiagnostics, + getDiagnosticParamsFor, -- * for tests - ) where +) where -import qualified Data.SortedList as SL -import qualified Data.Map.Strict as Map -import qualified Data.HashMap.Strict as HM -import qualified Language.LSP.Types as J +import Data.HashMap.Strict qualified as HM +import Data.Map.Strict qualified as Map +import Data.SortedList qualified as SL +import Data.Text (Text) +import Language.LSP.Protocol.Types qualified as J -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} {-# ANN module ("hlint: ignore Redundant do" :: String) #-} + -- --------------------------------------------------------------------- {- We need a three level store - Uri : Maybe TextDocumentVersion : Maybe DiagnosticSource : [Diagnostics] + Uri : Maybe Int32 : Maybe DiagnosticSource : [Diagnostics] -For a given Uri, as soon as we see a new (Maybe TextDocumentVersion) we flush +For a given Uri, as soon as we see a new (Maybe Int32) we flush all prior entries for the Uri. -} type DiagnosticStore = HM.HashMap J.NormalizedUri StoreItem -data StoreItem - = StoreItem J.TextDocumentVersion DiagnosticsBySource - deriving (Show,Eq) +data StoreItem = StoreItem + { documentVersion :: Maybe J.Int32 + , diagnostics :: DiagnosticsBySource + } + deriving (Show, Eq) -type DiagnosticsBySource = Map.Map (Maybe J.DiagnosticSource) (SL.SortedList J.Diagnostic) +type DiagnosticsBySource = Map.Map (Maybe Text) (SL.SortedList J.Diagnostic) -- --------------------------------------------------------------------- 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 -- --------------------------------------------------------------------- -flushBySource :: DiagnosticStore -> Maybe J.DiagnosticSource -> DiagnosticStore -flushBySource store Nothing = store +flushBySource :: DiagnosticStore -> Maybe Text -> DiagnosticStore +flushBySource store Nothing = store flushBySource store (Just source) = HM.map remove store - where - remove (StoreItem mv diags) = StoreItem mv (Map.delete (Just source) diags) + 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 + -- --------------------------------------------------------------------- -updateDiagnostics :: DiagnosticStore - -> J.NormalizedUri -> J.TextDocumentVersion -> DiagnosticsBySource - -> DiagnosticStore +updateDiagnostics :: + DiagnosticStore -> + J.NormalizedUri -> + Maybe J.Int32 -> + DiagnosticsBySource -> + DiagnosticStore updateDiagnostics store uri mv newDiagsBySource = r - where - newStore :: DiagnosticStore - newStore = HM.insert uri (StoreItem mv newDiagsBySource) store + where + newStore :: DiagnosticStore + newStore = HM.insert uri (StoreItem mv newDiagsBySource) store - updateDbs dbs = HM.insert uri new store - where - new = StoreItem mv newDbs - -- note: Map.union is left-biased, so for identical keys the first - -- argument is used - newDbs = Map.union newDiagsBySource dbs + updateDbs dbs = HM.insert uri new store + where + new = StoreItem mv newDbs + -- note: Map.union is left-biased, so for identical keys the first + -- argument is used + newDbs = Map.union newDiagsBySource dbs - r = case HM.lookup uri store of - Nothing -> newStore - Just (StoreItem mvs dbs) -> - if mvs /= mv - then newStore - else updateDbs dbs + r = case HM.lookup uri store of + Nothing -> newStore + Just (StoreItem mvs dbs) -> + if mvs /= mv + then newStore + else updateDbs dbs -- --------------------------------------------------------------------- @@ -92,6 +104,6 @@ case HM.lookup uri ds of Nothing -> Nothing Just (StoreItem mv diags) -> - Just $ J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (fmap fromIntegral mv) (J.List (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags)) + Just $ J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (fmap fromIntegral mv) (take maxDiagnostics $ SL.fromSortedList $ mconcat $ Map.elems diags) -- --------------------------------------------------------------------- diff --git a/src/Language/LSP/Logging.hs b/src/Language/LSP/Logging.hs --- a/src/Language/LSP/Logging.hs +++ b/src/Language/LSP/Logging.hs @@ -1,38 +1,43 @@ {-# LANGUAGE OverloadedStrings #-} + module Language.LSP.Logging (logToShowMessage, logToLogMessage, defaultClientLogger) where import Colog.Core -import Language.LSP.Server.Core -import Language.LSP.Types import Data.Text (Text) +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Server.Core logSeverityToMessageType :: Severity -> MessageType logSeverityToMessageType sev = case sev of - Error -> MtError - Warning -> MtWarning - Info -> MtInfo - Debug -> MtLog + Error -> MessageType_Error + Warning -> MessageType_Warning + Info -> MessageType_Info + Debug -> MessageType_Log -- | Logs messages to the client via @window/logMessage@. logToLogMessage :: (MonadLsp c m) => LogAction m (WithSeverity Text) logToLogMessage = LogAction $ \(WithSeverity msg sev) -> do - sendToClient $ fromServerNot $ - NotificationMessage "2.0" SWindowLogMessage (LogMessageParams (logSeverityToMessageType sev) msg) + sendToClient $ + fromServerNot $ + TNotificationMessage "2.0" SMethod_WindowLogMessage (LogMessageParams (logSeverityToMessageType sev) msg) -- | Logs messages to the client via @window/showMessage@. logToShowMessage :: (MonadLsp c m) => LogAction m (WithSeverity Text) logToShowMessage = LogAction $ \(WithSeverity msg sev) -> do - sendToClient $ fromServerNot $ - NotificationMessage "2.0" SWindowShowMessage (ShowMessageParams (logSeverityToMessageType sev) msg) + sendToClient $ + fromServerNot $ + TNotificationMessage "2.0" SMethod_WindowShowMessage (ShowMessageParams (logSeverityToMessageType sev) msg) --- | A 'sensible' log action for logging messages to the client: --- --- * Shows 'Error' logs to the user via @window/showMessage@ --- * Logs 'Info' and above logs in the client via @window/logMessage@ --- --- If you want finer control (e.g. the ability to log 'Debug' logs based on a flag, or similar), --- then do not use this and write your own based on 'logToShowMessage' and 'logToLogMessage'. +{- | A 'sensible' log action for logging messages to the client: + + * Shows 'Error' logs to the user via @window/showMessage@ + * Logs 'Info' and above logs in the client via @window/logMessage@ + + If you want finer control (e.g. the ability to log 'Debug' logs based on a flag, or similar), + then do not use this and write your own based on 'logToShowMessage' and 'logToLogMessage'. +-} defaultClientLogger :: (MonadLsp c m) => LogAction m (WithSeverity Text) defaultClientLogger = filterBySeverity Error getSeverity logToShowMessage - <> filterBySeverity Info getSeverity logToLogMessage + <> filterBySeverity Info getSeverity logToLogMessage 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,64 +1,71 @@ -{-# LANGUAGE TypeOperators #-} -module Language.LSP.Server - ( module Language.LSP.Server.Control - , VFSData(..) - , ServerDefinition(..) +{-# LANGUAGE ExplicitNamespaces #-} - -- * Handlers - , Handlers(..) - , Handler - , transmuteHandlers - , mapHandlers - , notificationHandler - , requestHandler - , ClientMessageHandler(..) +module Language.LSP.Server ( + module Language.LSP.Server.Control, + VFSData (..), + ServerDefinition (..), - , Options(..) - , defaultOptions + -- * Handlers + Handlers (..), + Handler, + transmuteHandlers, + mapHandlers, + notificationHandler, + requestHandler, + ClientMessageHandler (..), + Options (..), + defaultOptions, -- * LspT and LspM - , LspT(..) - , LspM - , MonadLsp(..) - , runLspT - , LanguageContextEnv(..) - , type (<~>)(..) + LspT (..), + LspM, + MonadLsp (..), + runLspT, + LanguageContextEnv (..), + type (<~>) (..), + getClientCapabilities, + getConfig, + setConfig, + getRootPath, + getWorkspaceFolders, + sendRequest, + sendNotification, - , getClientCapabilities - , getConfig - , setConfig - , getRootPath - , getWorkspaceFolders + -- * Config + requestConfigUpdate, + tryChangeConfig, - , sendRequest - , sendNotification + -- * Shutdown + isShuttingDown, + waitShuttingDown, -- * VFS - , getVirtualFile - , getVirtualFiles - , persistVirtualFile - , getVersionedTextDoc - , reverseFileMap - , snapshotVirtualFiles + getVirtualFile, + getVirtualFiles, + persistVirtualFile, + getVersionedTextDoc, + reverseFileMap, + snapshotVirtualFiles, -- * Diagnostics - , publishDiagnostics - , flushDiagnosticsBySource + publishDiagnostics, + flushDiagnosticsBySource, + flushDiagnosticsBySourceAndUri, -- * Progress - , withProgress - , withIndefiniteProgress - , ProgressAmount(..) - , ProgressCancellable(..) - , ProgressCancelledException + withProgress, + withIndefiniteProgress, + ProgressAmount (..), + ProgressCancellable (..), + ProgressCancelledException, -- * Dynamic registration - , registerCapability - , unregisterCapability - , RegistrationToken - - , reverseSortEdit - ) where + registerCapability, + unregisterCapability, + RegistrationToken, + reverseSortEdit, +) where 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,242 +1,444 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LambdaCase #-} - --- So we can keep using the old prettyprinter modules (which have a better --- compatibility range) for now. -{-# OPTIONS_GHC -Wno-deprecations #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -module Language.LSP.Server.Control - ( +module Language.LSP.Server.Control ( -- * Running - runServer - , runServerWith - , runServerWithHandles - , LspServerLog (..) - ) where + runServerWith, + runServerWithConfig, + ServerConfig (..), + LspServerLog (..), -import qualified Colog.Core as L -import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) -import Control.Concurrent -import Control.Concurrent.STM.TChan -import Control.Monad -import Control.Monad.STM -import Control.Monad.IO.Class -import qualified Data.Aeson as J -import qualified Data.Attoparsec.ByteString as Attoparsec + -- ** 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 +import Data.Aeson qualified as J +import Data.Attoparsec.ByteString qualified as Attoparsec import Data.Attoparsec.ByteString.Char8 -import qualified Data.ByteString as BS +import Data.ByteString qualified as BS import Data.ByteString.Builder.Extra (defaultChunkSize) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Text.Prettyprint.Doc -import Data.List -import Language.LSP.Server.Core -import qualified Language.LSP.Server.Processing as Processing -import Language.LSP.Types -import Language.LSP.VFS +import Data.ByteString.Lazy qualified as BSL +import Data.List +import Data.Text qualified as T +import Data.Text.Lazy qualified as TL +import Data.Text.Lazy.Encoding qualified as TL import Language.LSP.Logging (defaultClientLogger) -import System.IO +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 +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 [ - "Got error while decoding initialize:" + vsep + [ "Got error while decoding initialize:" , pretty err ] pretty (HeaderParseFail ctxs err) = - vsep [ - "Failed to parse message header:" + vsep + [ "Failed to parse message header:" , 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 -- --------------------------------------------------------------------- --- | Convenience function for 'runServerWithHandles' which: --- (1) reads from stdin; --- (2) writes to stdout; and --- (3) logs to stderr and to the client, with some basic filtering. -runServer :: forall config . ServerDefinition config -> IO Int +{- | Convenience function for 'runServerWithHandles' which: + (1) reads from stdin; + (2) writes to stdout; and + (3) logs to stderr and to the client, with some basic filtering. +-} +runServer :: forall config. ServerDefinition config -> IO Int runServer = runServerWithHandles - ioLogger - lspLogger - stdin - stdout - 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 + defaultIOLogger + defaultLspLogger + stdin + stdout --- | Starts a language server over the specified handles. --- This function will return once the @exit@ notification is received. +defaultIOLogger :: LogAction IO (WithSeverity LspServerLog) +defaultIOLogger = L.cmap (show . prettyMsg) L.logStringStderr + where + prettyMsg l = "[" <> viaShow (L.getSeverity l) <> "] " <> pretty (L.getMsg l) + +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. +-} runServerWithHandles :: - 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. - -> LogAction (LspM config) (WithSeverity LspServerLog) - -- ^ The logger to use once the server has started and can successfully send messages. - -> Handle - -- ^ Handle to read client input from. - -> Handle - -- ^ Handle to write output to. - -> ServerDefinition config - -> IO Int -- exit code + -- | The logger to use outside the main body of the server where we can't assume the ability to send messages. + LogAction IO (WithSeverity LspServerLog) -> + -- | The logger to use once the server has started and can successfully send messages. + LogAction (LspM config) (WithSeverity LspServerLog) -> + -- | Handle to read client input from. + Handle -> + -- | Handle to write output to. + Handle -> + ServerDefinition config -> + IO Int -- exit code runServerWithHandles ioLogger logger hin hout serverDefinition = do - hSetBuffering hin NoBuffering - hSetEncoding hin utf8 + hSetEncoding hin utf8 hSetBuffering hout NoBuffering - hSetEncoding hout utf8 + hSetEncoding hout utf8 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. -runServerWith :: - 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. - -> LogAction (LspM config) (WithSeverity LspServerLog) - -- ^ The logger to use once the server has started and can successfully send messages. - -> IO BS.ByteString - -- ^ Client input. - -> (BSL.ByteString -> IO ()) - -- ^ Function to provide output to. - -> ServerDefinition config - -> IO Int -- exit code -runServerWith ioLogger logger clientIn clientOut serverDefinition = do - - ioLogger <& Starting `WithSeverity` Info +{- | Starts listening and sending requests and responses + using the specified I/O. - cout <- atomically newTChan :: IO (TChan J.Value) - _rhpid <- forkIO $ sendServer ioLogger cout clientOut + 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. + LogAction IO (WithSeverity LspServerLog) -> + -- | The logger to use once the server has started and can successfully send messages. + LogAction (LspM config) (WithSeverity LspServerLog) -> + -- | Client input. + IO BS.StrictByteString -> + -- | Function to provide output to. + (BSL.LazyByteString -> IO ()) -> + ServerDefinition config -> + IO Int -- exit code +runServerWith ioLogger lspLogger inwards outwards = + runServerWithConfig ServerConfig{prepareOutwards = prependHeader, parseInwards = parseHeaders, ..} - let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg +-- --------------------------------------------------------------------- - initVFS $ \vfs -> do - ioLoop ioLogger logger clientIn serverDefinition vfs 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 -- --------------------------------------------------------------------- ioLoop :: - forall config - . LogAction IO (WithSeverity LspServerLog) - -> LogAction (LspM config) (WithSeverity LspServerLog) - -> IO BS.ByteString - -> ServerDefinition config - -> VFS - -> (FromServerMessage -> IO ()) - -> IO () -ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg = do + forall config. + LogAction IO (WithSeverity LspServerLog) -> + LogAction (LspM config) (WithSeverity LspServerLog) -> + IO BS.StrictByteString -> + Attoparsec.Parser BS.StrictByteString -> + ServerDefinition config -> + VFS -> + (FromServerMessage -> IO ()) -> + IO () -> + IO Int +ioLoop ioLogger logger clientIn parser serverDefinition vfs sendMsg waitSenderFinish = do minitialize <- parseOne ioLogger clientIn (parse parser "") case minitialize of - Nothing -> pure () - Just (msg,remainder) -> do + 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 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 + where + pioLogger = L.cmap (fmap LspProcessingLog) ioLogger + pLogger = L.cmap (fmap LspProcessingLog) logger - loop :: Result BS.ByteString -> LspM config () - loop = go - where - pLogger = L.cmap (fmap LspProcessingLog) logger - go r = do + loop = go + where + go r = do + b <- isExiting + if b + then pure 0 + else do res <- parseOne logger clientIn r case res of - Nothing -> pure () - Just (msg,remainder) -> do + Nothing -> pure 1 + Just (msg, remainder) -> do Processing.processMessage pLogger $ BSL.fromStrict msg go (parse parser remainder) - parser = do - _ <- string "Content-Length: " - len <- decimal - _ <- string _TWO_CRLF - Attoparsec.take len - parseOne :: - MonadIO m - => LogAction m (WithSeverity LspServerLog) - -> IO BS.ByteString - -> Result BS.ByteString - -> m (Maybe (BS.ByteString,BS.ByteString)) + MonadIO m => + LogAction m (WithSeverity LspServerLog) -> + IO BS.StrictByteString -> + Result BS.StrictByteString -> + m (Maybe (BS.ByteString, BS.ByteString)) parseOne logger clientIn = go - where - go (Fail _ ctxs err) = do - logger <& HeaderParseFail ctxs err `WithSeverity` Error - 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 (Done remainder msg) = do - logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug - pure $ Just (msg,remainder) + where + go (Fail _ ctxs err) = do + logger <& HeaderParseFail ctxs err `WithSeverity` Error + pure Nothing + go (Partial c) = do + bs <- liftIO clientIn + 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 + -- logger <& ParsedMsg (T.decodeUtf8 msg) `WithSeverity` Debug + pure $ Just (msg, remainder) -- --------------------------------------------------------------------- +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 - logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug + -- close the client sender when we send out the shutdown request's response + case msg of + FromServerRsp SMethod_Shutdown _ -> pure () + _ -> go --- | --- --- -_TWO_CRLF :: BS.ByteString -_TWO_CRLF = "\r\n\r\n" +-- 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 +-- | 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.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,740 +1,908 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE BinaryLiterals #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RoleAnnotations #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -fprint-explicit-kinds #-} - - -module Language.LSP.Server.Core where - -import Colog.Core (LogAction (..), WithSeverity (..)) -import Control.Concurrent.Async -import Control.Concurrent.STM -import qualified Control.Exception as E -import Control.Monad -import Control.Monad.Fix -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class -import Control.Monad.IO.Unlift -import Control.Lens ( (^.), (^?), _Just, at) -import qualified Data.Aeson as J -import Data.Default -import Data.Functor.Product -import Data.IxMap -import qualified Data.HashMap.Strict as HM -import Data.Kind -import qualified Data.List as L -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Map.Strict as Map -import Data.Maybe -import Data.Monoid (Ap(..)) -import Data.Ord (Down (Down)) -import qualified Data.Text as T -import Data.Text ( Text ) -import qualified Data.UUID as UUID -import qualified Language.LSP.Types.Capabilities as J -import Language.LSP.Types as J -import Language.LSP.Types.SMethodMap (SMethodMap) -import qualified Language.LSP.Types.SMethodMap as SMethodMap -import qualified Language.LSP.Types.Lens as J -import Language.LSP.VFS -import Language.LSP.Diagnostics -import System.Random hiding (next) -import Control.Monad.Trans.Identity -import Control.Monad.Catch (MonadMask, MonadCatch, MonadThrow) - --- --------------------------------------------------------------------- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} --- --------------------------------------------------------------------- - -newtype LspT config m a = LspT { unLspT :: ReaderT (LanguageContextEnv config) m a } - deriving (Functor, Applicative, Monad, MonadCatch, MonadIO, MonadMask, MonadThrow, MonadTrans, MonadUnliftIO, MonadFix) - deriving (Semigroup, Monoid) via (Ap (LspT config m) a) - --- for deriving the instance of MonadUnliftIO -type role LspT representational representational nominal - -runLspT :: LanguageContextEnv config -> LspT config m a -> m a -runLspT env = flip runReaderT env . unLspT - -{-# INLINE runLspT #-} - -type LspM config = LspT config IO - -class MonadUnliftIO m => MonadLsp config m | m -> config where - getLspEnv :: m (LanguageContextEnv config) - -instance MonadUnliftIO m => MonadLsp config (LspT config m) where - {-# SPECIALIZE instance MonadLsp config (LspT config IO) #-} - {-# INLINE getLspEnv #-} - getLspEnv = LspT ask - -instance MonadLsp c m => MonadLsp c (ReaderT r m) where - {-# SPECIALIZE instance MonadLsp config (ReaderT r (LspT config IO)) #-} - {-# INLINE getLspEnv #-} - getLspEnv = lift getLspEnv - -instance MonadLsp c m => MonadLsp c (IdentityT m) where - getLspEnv = lift getLspEnv - -data LanguageContextEnv config = - LanguageContextEnv - { resHandlers :: !(Handlers IO) - , resParseConfig :: !(config -> J.Value -> Either T.Text config) - , resSendMessage :: !(FromServerMessage -> IO ()) - -- We keep the state in a TVar to be thread safe - , resState :: !(LanguageContextState config) - , resClientCapabilities :: !J.ClientCapabilities - , resRootPath :: !(Maybe FilePath) - } - --- --------------------------------------------------------------------- --- Handlers --- --------------------------------------------------------------------- - --- | A mapping from methods to the static 'Handler's that should be used to --- handle responses when they come in from the client. To build up a 'Handlers', --- you should 'mconcat' a list of 'notificationHandler' and 'requestHandler's: --- --- @ --- mconcat [ --- notificationHandler SInitialized $ \notif -> pure () --- , requestHandler STextDocumentHover $ \req responder -> pure () --- ] --- @ -data Handlers m - = Handlers - { reqHandlers :: !(SMethodMap (ClientMessageHandler m Request)) - , notHandlers :: !(SMethodMap (ClientMessageHandler m Notification)) - } -instance Semigroup (Handlers config) where - Handlers r1 n1 <> Handlers r2 n2 = Handlers (r1 <> r2) (n1 <> n2) -instance Monoid (Handlers config) where - mempty = Handlers mempty mempty - -notificationHandler :: forall (m :: Method FromClient Notification) f. SMethod m -> Handler f m -> Handlers f -notificationHandler m h = Handlers mempty (SMethodMap.singleton m (ClientMessageHandler h)) - -requestHandler :: forall (m :: Method FromClient Request) f. SMethod m -> Handler f m -> Handlers f -requestHandler m h = Handlers (SMethodMap.singleton m (ClientMessageHandler h)) mempty - --- | Wrapper to restrict 'Handler's to 'FromClient' 'Method's -newtype ClientMessageHandler f (t :: MethodType) (m :: Method FromClient t) = ClientMessageHandler (Handler f m) - --- | The type of a handler that handles requests and notifications coming in --- 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) = RequestMessage m -> (Either ResponseError (ResponseResult m) -> f ()) -> f () - Handler f (m :: Method _from Notification) = NotificationMessage m -> f () - --- | How to convert two isomorphic data structures between each other. -data m <~> n - = Iso - { forward :: forall a. m a -> n a - , backward :: forall a. n a -> m a - } - -transmuteHandlers :: (m <~> n) -> Handlers m -> Handlers n -transmuteHandlers nat = mapHandlers (\i m k -> forward nat (i m (backward nat . k))) (\i m -> forward nat (i m)) - -mapHandlers - :: (forall (a :: Method FromClient Request). Handler m a -> Handler n a) - -> (forall (a :: Method FromClient Notification). Handler m a -> Handler n a) - -> Handlers m -> Handlers n -mapHandlers mapReq mapNot (Handlers reqs nots) = Handlers reqs' nots' - where - reqs' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapReq i) reqs - nots' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapNot i) nots - --- | state used by the LSP dispatcher to manage the message loop -data LanguageContextState config = - LanguageContextState - { resVFS :: !(TVar VFSData) - , resDiagnostics :: !(TVar DiagnosticStore) - , resConfig :: !(TVar config) - , resWorkspaceFolders :: !(TVar [WorkspaceFolder]) - , resProgressData :: !ProgressData - , resPendingResponses :: !(TVar ResponseMap) - , resRegistrationsNot :: !(TVar (RegistrationMap Notification)) - , resRegistrationsReq :: !(TVar (RegistrationMap Request)) - , resLspId :: !(TVar Int32) - } - -type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback) - -type RegistrationMap (t :: MethodType) = SMethodMap (Product RegistrationId (ClientMessageHandler IO t)) - -data RegistrationToken (m :: Method FromClient t) = RegistrationToken (SMethod m) (RegistrationId m) -newtype RegistrationId (m :: Method FromClient t) = RegistrationId Text - deriving Eq - -data ProgressData = ProgressData { progressNextId :: !(TVar Int32) - , progressCancel :: !(TVar (Map.Map ProgressToken (IO ()))) } - -data VFSData = - VFSData - { vfsData :: !VFS - , reverseMap :: !(Map.Map FilePath FilePath) - } - -{-# INLINE modifyState #-} -modifyState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> (a -> a) -> m () -modifyState sel f = do - tvarDat <- sel . resState <$> getLspEnv - 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 - liftIO $ atomically $ stateTVar tvarDat f - -{-# INLINE getsState #-} -getsState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m a -getsState f = do - tvarDat <- f . resState <$> getLspEnv - liftIO $ readTVarIO tvarDat - --- --------------------------------------------------------------------- - --- | Language Server Protocol 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 - { textDocumentSync :: Maybe J.TextDocumentSyncOptions - -- | The characters that trigger completion automatically. - , completionTriggerCharacters :: Maybe [Char] - -- | The list of all possible characters that commit a completion. This field can be used - -- if clients don't support individual commit characters per completion item. See - -- `_commitCharactersSupport`. - , completionAllCommitCharacters :: Maybe [Char] - -- | The characters that trigger signature help automatically. - , signatureHelpTriggerCharacters :: Maybe [Char] - -- | List of characters that re-trigger signature help. - -- These trigger characters are only active when signature help is already showing. All trigger characters - -- are also counted as re-trigger characters. - , signatureHelpRetriggerCharacters :: Maybe [Char] - -- | CodeActionKinds that this server may return. - -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server - -- may list out every specific kind they provide. - , codeActionKinds :: Maybe [CodeActionKind] - -- | The list of characters that triggers on type formatting. - -- If you set `documentOnTypeFormattingHandler`, you **must** set this. - -- The first character is mandatory, so a 'NonEmpty' should be passed. - , documentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) - -- | The commands to be executed on the server. - -- If you set `executeCommandHandler`, you **must** set this. - , executeCommandCommands :: Maybe [Text] - -- | Information about the server that can be advertised to the client. - , serverInfo :: Maybe J.ServerInfo - } - -instance Default Options where - def = Options Nothing Nothing Nothing 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 - --- | 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. - ServerDefinition - { defaultConfig :: config - -- ^ The default value we initialize the config variable to. - , onConfigurationChange :: config -> J.Value -> Either T.Text config - -- ^ @onConfigurationChange oldConfig newConfig@ is called whenever the - -- clients sends a message with a changed client configuration. This - -- callback should return either the parsed configuration data or an error - -- indicating what went wrong. The parsed configuration object will be - -- stored internally and can be accessed via 'config'. - -- It is also called on the `initializationOptions` field of the InitializeParams - , doInitialize :: LanguageContextEnv config -> Message Initialize -> IO (Either ResponseError 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 - -- start new threads that may be necessary for the server lifecycle. It can - -- also return an error in the initialization if necessary. - , staticHandlers :: Handlers m - -- ^ Handlers for any methods you want to statically support. - -- The handlers here cannot be unregistered during the server's lifetime - -- and will be registered statically in the initialize request. - , interpretHandler :: a -> (m <~> IO) - -- ^ How to run the handlers in your own monad of choice, @m@. - -- It is passed the result of 'doInitialize', so typically you will want - -- to thread along the 'LanguageContextEnv' as well as any other state you - -- need to run your monad. @m@ should most likely be built on top of - -- 'LspT'. - -- - -- @ - -- ServerDefinition { ... - -- , doInitialize = \env _req -> pure $ Right env - -- , interpretHandler = \env -> Iso - -- (runLspT env) -- how to convert from IO ~> m - -- liftIO -- how to convert from m ~> IO - -- } - -- @ - , options :: Options - -- ^ Configurable options for the server's capabilities. - } - --- | A function that a 'Handler' is passed that can be used to respond to a --- request with either an error, or the response params. -newtype ServerResponseCallback (m :: Method FromServer Request) - = ServerResponseCallback (Either ResponseError (ResponseResult m) -> IO ()) - --- | Return value signals if response handler was inserted successfully --- Might fail if the id was already in the map -addResponseHandler :: MonadLsp config f => LspId m -> (Product SMethod ServerResponseCallback) m -> f Bool -addResponseHandler lid h = do - stateState resPendingResponses $ \pending -> - case insertIxMap lid h pending of - Just !m -> (True, m) - Nothing -> (False, pending) - -sendNotification - :: forall (m :: Method FromServer Notification) f config. MonadLsp config f - => SServerMethod m - -> MessageParams m - -> f () -sendNotification m params = - let msg = NotificationMessage "2.0" m params - in case splitServerMethod m of - IsServerNot -> sendToClient $ fromServerNot msg - IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg - -sendRequest :: forall (m :: Method FromServer Request) f config. MonadLsp config f - => SServerMethod m - -> MessageParams m - -> (Either ResponseError (ResponseResult m) -> f ()) - -> f (LspId m) -sendRequest m params resHandler = do - reqId <- IdInt <$> freshLspId - rio <- askRunInIO - success <- addResponseHandler reqId (Pair m (ServerResponseCallback (rio . resHandler))) - unless success $ error "LSP: could not send FromServer request as id is reused" - - let msg = RequestMessage "2.0" reqId m params - ~() <- case splitServerMethod m of - IsServerReq -> sendToClient $ fromServerReq msg - IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg - return reqId - --- --------------------------------------------------------------------- - --- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. -getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) -getVirtualFile uri = do - dat <- vfsData <$> getsState resVFS - pure $ dat ^. vfsMap . at uri - -{-# INLINE getVirtualFile #-} - -getVirtualFiles :: MonadLsp config m => m VFS -getVirtualFiles = vfsData <$> getsState resVFS - -{-# INLINE getVirtualFiles #-} - --- | Take an atomic snapshot of the current state of the virtual file system. -snapshotVirtualFiles :: LanguageContextEnv c -> STM VFS -snapshotVirtualFiles env = vfsData <$> readTVar (resVFS $ resState env) - -{-# INLINE snapshotVirtualFiles #-} - - --- | Dump the current text for a given VFS file to a temporary file, --- and return the path to the file. -persistVirtualFile :: MonadLsp config m => LogAction m (WithSeverity VfsLog) -> NormalizedUri -> m (Maybe FilePath) -persistVirtualFile logger uri = do - join $ stateState resVFS $ \vfs -> - case persistFileVFS logger (vfsData vfs) uri of - Nothing -> (return Nothing, vfs) - Just (fn, write) -> - let !revMap = case uriToFilePath (fromNormalizedUri uri) of - Just uri_fp -> Map.insert fn uri_fp $ reverseMap vfs - -- TODO: Does the VFS make sense for URIs which are not files? - -- The reverse map should perhaps be (FilePath -> URI) - Nothing -> reverseMap vfs - !vfs' = vfs {reverseMap = revMap} - act = do - write - pure (Just fn) - in (act, vfs') - --- | Given a text document identifier, annotate it with the latest version. -getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier -getVersionedTextDoc doc = do - let uri = doc ^. J.uri - mvf <- getVirtualFile (toNormalizedUri uri) - let ver = case mvf of - Just (VirtualFile lspver _ _) -> Just lspver - Nothing -> Nothing - return (VersionedTextDocumentIdentifier uri ver) - -{-# INLINE getVersionedTextDoc #-} - --- TODO: should this function return a URI? --- | If the contents of a VFS has been dumped to a temporary file, map --- the temporary file name back to the original one. -reverseFileMap :: MonadLsp config m => m (FilePath -> FilePath) -reverseFileMap = do - vfs <- getsState resVFS - let f fp = fromMaybe fp . Map.lookup fp . reverseMap $ vfs - return f - -{-# INLINE reverseFileMap #-} - --- --------------------------------------------------------------------- - -sendToClient :: MonadLsp config m => FromServerMessage -> m () -sendToClient msg = do - f <- resSendMessage <$> getLspEnv - liftIO $ f msg - -{-# INLINE sendToClient #-} - --- --------------------------------------------------------------------- - -freshLspId :: MonadLsp config m => m Int32 -freshLspId = do - stateState resLspId $ \cur -> - let !next = cur+1 in (cur, next) - -{-# INLINE freshLspId #-} - --- --------------------------------------------------------------------- - --- | The current configuration from the client as set via the @initialize@ and --- @workspace/didChangeConfiguration@ requests, as well as by calls to --- 'setConfig'. -getConfig :: MonadLsp config m => m config -getConfig = getsState resConfig - -{-# INLINE getConfig #-} - -setConfig :: MonadLsp config m => config -> m () -setConfig config = stateState resConfig (const ((), config)) - -{-# INLINE setConfig #-} - -getClientCapabilities :: MonadLsp config m => m J.ClientCapabilities -getClientCapabilities = resClientCapabilities <$> getLspEnv - -{-# INLINE getClientCapabilities #-} - -getRootPath :: MonadLsp config m => m (Maybe FilePath) -getRootPath = resRootPath <$> getLspEnv - -{-# INLINE getRootPath #-} - --- | The current workspace folders, if the client supports workspace folders. -getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder]) -getWorkspaceFolders = do - clientCaps <- getClientCapabilities - let clientSupportsWfs = fromMaybe False $ do - let (J.ClientCapabilities mw _ _ _ _) = clientCaps - (J.WorkspaceClientCapabilities _ _ _ _ _ _ mwf _ _) <- mw - mwf - if clientSupportsWfs - then Just <$> getsState resWorkspaceFolders - else pure Nothing - -{-# INLINE getWorkspaceFolders #-} - --- | Sends a @client/registerCapability@ request and dynamically registers --- a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not --- support dynamic registration for the specified method, otherwise a --- 'RegistrationToken' which can be used to unregister it later. -registerCapability :: forall f t (m :: Method FromClient t) config. - MonadLsp config f - => SClientMethod m - -> RegistrationOptions m - -> Handler f m - -> f (Maybe (RegistrationToken m)) -registerCapability method regOpts f = do - clientCaps <- resClientCapabilities <$> getLspEnv - 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 - 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 - | dynamicSupported clientCaps = do - uuid <- liftIO $ UUID.toText <$> getStdRandom random - let registration = J.Registration uuid method regOpts - params = J.RegistrationParams (J.List [J.SomeRegistration registration]) - regId = RegistrationId uuid - rio <- askUnliftIO - ~() <- case splitClientMethod method of - IsClientNot -> modifyState resRegistrationsNot $ \oldRegs -> - let pair = Pair regId (ClientMessageHandler (unliftIO rio . f)) - in SMethodMap.insert method pair oldRegs - IsClientReq -> modifyState resRegistrationsReq $ \oldRegs -> - let pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) - in SMethodMap.insert method pair oldRegs - IsClientEither -> error "Cannot register capability for custom methods" - - -- TODO: handle the scenario where this returns an error - _ <- sendRequest SClientRegisterCapability params $ \_res -> pure () - - pure (Just (RegistrationToken method regId)) - | otherwise = pure Nothing - - -- Also I'm thinking we should move this function to somewhere in messages.hs so - -- we don't forget to update it when adding new methods... - capDyn :: J.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool - capDyn (Just x) = fromMaybe False $ x ^. J.dynamicRegistration - capDyn Nothing = False - - -- | Checks if client capabilities declares that the method supports dynamic registration - dynamicSupported clientCaps = case method of - SWorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeConfiguration . _Just - SWorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? J.workspace . _Just . J.didChangeWatchedFiles . _Just - SWorkspaceSymbol -> capDyn $ clientCaps ^? J.workspace . _Just . J.symbol . _Just - SWorkspaceExecuteCommand -> capDyn $ clientCaps ^? J.workspace . _Just . J.executeCommand . _Just - STextDocumentDidOpen -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentDidChange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentDidClose -> capDyn $ clientCaps ^? J.textDocument . _Just . J.synchronization . _Just - STextDocumentCompletion -> capDyn $ clientCaps ^? J.textDocument . _Just . J.completion . _Just - STextDocumentHover -> capDyn $ clientCaps ^? J.textDocument . _Just . J.hover . _Just - STextDocumentSignatureHelp -> capDyn $ clientCaps ^? J.textDocument . _Just . J.signatureHelp . _Just - STextDocumentDeclaration -> capDyn $ clientCaps ^? J.textDocument . _Just . J.declaration . _Just - STextDocumentDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.definition . _Just - STextDocumentTypeDefinition -> capDyn $ clientCaps ^? J.textDocument . _Just . J.typeDefinition . _Just - STextDocumentImplementation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.implementation . _Just - STextDocumentReferences -> capDyn $ clientCaps ^? J.textDocument . _Just . J.references . _Just - STextDocumentDocumentHighlight -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentHighlight . _Just - STextDocumentDocumentSymbol -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentSymbol . _Just - STextDocumentCodeAction -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeAction . _Just - STextDocumentCodeLens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.codeLens . _Just - STextDocumentDocumentLink -> capDyn $ clientCaps ^? J.textDocument . _Just . J.documentLink . _Just - STextDocumentDocumentColor -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just - STextDocumentColorPresentation -> capDyn $ clientCaps ^? J.textDocument . _Just . J.colorProvider . _Just - STextDocumentFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.formatting . _Just - STextDocumentRangeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rangeFormatting . _Just - STextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? J.textDocument . _Just . J.onTypeFormatting . _Just - STextDocumentRename -> capDyn $ clientCaps ^? J.textDocument . _Just . J.rename . _Just - STextDocumentFoldingRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.foldingRange . _Just - STextDocumentSelectionRange -> capDyn $ clientCaps ^? J.textDocument . _Just . J.selectionRange . _Just - STextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? J.textDocument . _Just . J.callHierarchy . _Just - STextDocumentSemanticTokens -> capDyn $ clientCaps ^? J.textDocument . _Just . J.semanticTokens . _Just - _ -> False - --- | Sends a @client/unregisterCapability@ request and removes the handler --- for that associated registration. -unregisterCapability :: MonadLsp config f => RegistrationToken m -> f () -unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do - ~() <- case splitClientMethod m of - IsClientReq -> modifyState resRegistrationsReq $ SMethodMap.delete m - IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m - IsClientEither -> error "Cannot unregister capability for custom methods" - - let unregistration = J.Unregistration uuid (J.SomeClientMethod m) - params = J.UnregistrationParams (J.List [unregistration]) - void $ sendRequest SClientUnregisterCapability 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 (ProgressNumericToken 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 SWindowWorkDoneProgressCreate - (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 Empty -> 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 SProgress $ - fmap Begin $ ProgressParams progId $ - WorkDoneProgressBeginParams title (Just cancellable') Nothing initialPercentage) - - -- Send end notification - (runInBase $ sendNotification SProgress $ - End <$> ProgressParams progId (WorkDoneProgressEndParams 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 SProgress $ fmap Report $ ProgressParams progId $ - WorkDoneProgressReportParams Nothing msg percentage - -clientSupportsProgress :: J.ClientCapabilities -> Bool -clientSupportsProgress (J.ClientCapabilities _ _ wc _ _) = fromMaybe False $ do - (J.WindowClientCapabilities mProgress _ _) <- wc - mProgress - -{-# 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, --- by source, and sends a @textDocument/publishDiagnostics@ notification with --- the total (limited by the first parameter) whenever it is updated. -publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> m () -publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState resDiagnostics $ \oldDiags-> - let !newDiags = updateDiagnostics oldDiags uri version diags - mdp = getDiagnosticParamsFor maxDiagnosticCount newDiags uri - act = case mdp of - Nothing -> return () - Just params -> - sendToClient $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics params - in (act,newDiags) - --- --------------------------------------------------------------------- - --- | Remove all diagnostics from a particular source, and send the updates to --- the client. -flushDiagnosticsBySource :: MonadLsp config m => Int -- ^ Max number of diagnostics to send - -> Maybe DiagnosticSource -> m () -flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState resDiagnostics $ \oldDiags -> - let !newDiags = flushBySource oldDiags msource - -- 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 $ J.fromServerNot $ J.NotificationMessage "2.0" J.STextDocumentPublishDiagnostics 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. -reverseSortEdit :: J.WorkspaceEdit -> J.WorkspaceEdit -reverseSortEdit (J.WorkspaceEdit cs dcs anns) = J.WorkspaceEdit cs' dcs' anns - where - cs' :: Maybe J.WorkspaceEditMap - cs' = (fmap . fmap ) sortTextEdits cs - - dcs' :: Maybe (J.List J.DocumentChange) - dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs - - sortTextEdits :: J.List J.TextEdit -> J.List J.TextEdit - sortTextEdits (J.List edits) = J.List (L.sortOn (Down . (^. J.range)) edits) - - sortOnlyTextDocumentEdits :: J.DocumentChange -> J.DocumentChange - sortOnlyTextDocumentEdits (J.InL (J.TextDocumentEdit td (J.List edits))) = J.InL $ J.TextDocumentEdit td (J.List edits') - where - edits' = L.sortOn (Down . editRange) edits - sortOnlyTextDocumentEdits (J.InR others) = J.InR others - - editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range - editRange (J.InR e) = e ^. J.range - editRange (J.InL e) = e ^. J.range +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CUSKs #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -fprint-explicit-kinds #-} + +module Language.LSP.Server.Core where + +import Colog.Core ( + LogAction (..), + Severity (..), + WithSeverity (..), + (<&), + ) +import Control.Concurrent.Extra as C +import Control.Concurrent.STM +import Control.Lens (ix, (^.), (^?), _Just) +import Control.Monad +import Control.Monad.Catch ( + MonadCatch, + MonadMask, + MonadThrow, + ) +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.IO.Unlift +import Control.Monad.Trans.Class +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Reader +import Data.Aeson qualified as J +import Data.Default +import Data.Functor.Product +import Data.HashMap.Strict qualified as HM +import Data.IxMap +import Data.Kind +import Data.List qualified as L +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Maybe +import Data.Monoid (Ap (..)) +import Data.Ord (Down (Down)) +import Data.Text (Text) +import Data.Text qualified as T +import Language.LSP.Diagnostics +import Language.LSP.Protocol.Capabilities +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Message qualified as L +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Types qualified as L +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 hiding (end) +import Prettyprinter + +-- --------------------------------------------------------------------- +{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} + +-- --------------------------------------------------------------------- + +data LspCoreLog + = -- TODO: arguably it would be nicer to have the config object itself in there, but + -- then we're going to need 'Pretty config' constraints everywhere + NewConfig J.Value + | ConfigurationParseError J.Value T.Text + | ConfigurationNotSupported + | BadConfigurationResponse (TResponseError Method_WorkspaceConfiguration) + | WrongConfigSections [J.Value] + | 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 (ConfigurationParseError settings err) = + vsep + [ "LSP: configuration parse error:" + , pretty err + , "when parsing" + , 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 (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) + deriving (Semigroup, Monoid) via (Ap (LspT config m) a) + +-- for deriving the instance of MonadUnliftIO +type role LspT representational representational nominal + +runLspT :: LanguageContextEnv config -> LspT config m a -> m a +runLspT env = flip runReaderT env . unLspT +{-# INLINE runLspT #-} + +type LspM config = LspT config IO + +class MonadUnliftIO m => MonadLsp config m | m -> config where + getLspEnv :: m (LanguageContextEnv config) + +instance MonadUnliftIO m => MonadLsp config (LspT config m) where + {-# SPECIALIZE instance MonadLsp config (LspT config IO) #-} + {-# INLINE getLspEnv #-} + getLspEnv = LspT ask + +instance MonadLsp c m => MonadLsp c (ReaderT r m) where + {-# SPECIALIZE instance MonadLsp config (ReaderT r (LspT config IO)) #-} + {-# INLINE getLspEnv #-} + getLspEnv = lift getLspEnv + +instance MonadLsp c m => MonadLsp c (IdentityT m) where + getLspEnv = lift getLspEnv + +data LanguageContextEnv config = LanguageContextEnv + { resHandlers :: !(Handlers IO) + , resConfigSection :: T.Text + , resParseConfig :: !(config -> J.Value -> Either T.Text config) + , resOnConfigChange :: !(config -> IO ()) + , resSendMessage :: !(FromServerMessage -> IO ()) + , -- We keep the state in a TVar to be thread safe + 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] + } + +-- --------------------------------------------------------------------- +-- Handlers +-- --------------------------------------------------------------------- + +{- | A mapping from methods to the static 'Handler's that should be used to + handle responses when they come in from the client. To build up a 'Handlers', + you should 'mconcat' a list of 'notificationHandler' and 'requestHandler's: + + @ + mconcat [ + notificationHandler SInitialized $ \notif -> pure () + , requestHandler STextDocumentHover $ \req responder -> pure () + ] + @ +-} +data Handlers m = Handlers + { reqHandlers :: !(SMethodMap (ClientMessageHandler m Request)) + , notHandlers :: !(SMethodMap (ClientMessageHandler m Notification)) + } + +instance Semigroup (Handlers config) where + Handlers r1 n1 <> Handlers r2 n2 = Handlers (r1 <> r2) (n1 <> n2) +instance Monoid (Handlers config) where + mempty = Handlers mempty mempty + +notificationHandler :: forall (m :: Method ClientToServer Notification) f. SMethod m -> Handler f m -> Handlers f +notificationHandler m h = Handlers mempty (SMethodMap.singleton m (ClientMessageHandler h)) + +requestHandler :: forall (m :: Method ClientToServer Request) f. SMethod m -> Handler f m -> Handlers f +requestHandler m h = Handlers (SMethodMap.singleton m (ClientMessageHandler h)) mempty + +-- | Wrapper to restrict 'Handler's to ClientToServer' 'Method's +newtype ClientMessageHandler f (t :: MessageKind) (m :: Method ClientToServer t) = ClientMessageHandler (Handler f m) + +{- | The type of a handler that handles requests and notifications coming in + 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 (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. +data m <~> n = Iso + { forward :: forall a. m a -> n a + , backward :: forall a. n a -> m a + } + +transmuteHandlers :: (m <~> n) -> Handlers m -> Handlers n +transmuteHandlers nat = mapHandlers (\i m k -> forward nat (i m (backward nat . k))) (\i m -> forward nat (i m)) + +mapHandlers :: + (forall (a :: Method ClientToServer Request). Handler m a -> Handler n a) -> + (forall (a :: Method ClientToServer Notification). Handler m a -> Handler n a) -> + Handlers m -> + Handlers n +mapHandlers mapReq mapNot (Handlers reqs nots) = Handlers reqs' nots' + where + reqs' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapReq i) reqs + nots' = SMethodMap.map (\(ClientMessageHandler i) -> ClientMessageHandler $ mapNot i) nots + +-- | state used by the LSP dispatcher to manage the message loop +data LanguageContextState config = LanguageContextState + { resVFS :: !(TVar VFSData) + , resDiagnostics :: !(TVar DiagnosticStore) + , resConfig :: !(TVar config) + , resWorkspaceFolders :: !(TVar [WorkspaceFolder]) + , resProgressData :: !ProgressData + , resPendingResponses :: !(TVar ResponseMap) + , 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) + +type RegistrationMap (t :: MessageKind) = SMethodMap (Product RegistrationId (ClientMessageHandler IO t)) + +data RegistrationToken (m :: Method ClientToServer t) = RegistrationToken (SMethod m) (RegistrationId m) +newtype RegistrationId (m :: Method ClientToServer t) = RegistrationId Text + deriving (Eq) + +data ProgressData = ProgressData + { progressNextId :: !(TVar Int32) + , progressCancel :: !(TVar (Map.Map ProgressToken (IO ()))) + } + +data VFSData = VFSData + { vfsData :: !VFS + , reverseMap :: !(Map.Map FilePath FilePath) + } + +{-# INLINE modifyState #-} +modifyState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> (a -> a) -> m () +modifyState sel f = do + 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 <- getStateVar sel + liftIO $ atomically $ stateTVar tvarDat f + +{-# INLINE getsState #-} +getsState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m a +getsState f = do + tvarDat <- getStateVar f + liftIO $ readTVarIO tvarDat + +{-# INLINE getStateVar #-} +getStateVar :: MonadLsp config m => (LanguageContextState config -> TVar a) -> m (TVar a) +getStateVar f = f . resState <$> getLspEnv + +-- --------------------------------------------------------------------- + +{- | 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 + { optTextDocumentSync :: Maybe L.TextDocumentSyncOptions + , optCompletionTriggerCharacters :: Maybe [Char] + -- ^ The characters that trigger completion automatically. + , optCompletionAllCommitCharacters :: Maybe [Char] + -- ^ The list of all possible characters that commit a completion. This field can be used + -- if clients don't support individual commit characters per completion item. See + -- `_commitCharactersSupport`. + , optSignatureHelpTriggerCharacters :: Maybe [Char] + -- ^ The characters that trigger signature help automatically. + , optSignatureHelpRetriggerCharacters :: Maybe [Char] + -- ^ List of characters that re-trigger signature help. + -- These trigger characters are only active when signature help is already showing. All trigger characters + -- are also counted as re-trigger characters. + , optCodeActionKinds :: Maybe [CodeActionKind] + -- ^ CodeActionKinds that this server may return. + -- The list of kinds may be generic, such as `CodeActionKind.Refactor`, or the server + -- may list out every specific kind they provide. + , optDocumentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char) + -- ^ The list of characters that triggers on type formatting. + -- If you set `documentOnTypeFormattingHandler`, you **must** set this. + -- The first character is mandatory, so a 'NonEmpty' should be passed. + , optExecuteCommandCommands :: Maybe [Text] + -- ^ The commands to be executed on the server. + -- If you set `executeCommandHandler`, you **must** set this. + , 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 + def = + Options + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + False + -- See Note [Delayed progress reporting] + 0 + 0 + Nothing + Nothing + Nothing + Nothing + Nothing + Nothing + +defaultOptions :: Options +defaultOptions = def + +-- 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. + ServerDefinition + { defaultConfig :: config + -- ^ The default value we initialize the config variable to. + , configSection :: T.Text + -- ^ The "config section" that this server uses. This is used to identify the settings + -- that are relevant to the server. + , parseConfig :: config -> J.Value -> Either T.Text config + -- ^ @parseConfig oldConfig newConfigObject@ is called whenever we + -- get updated configuration from the client. + -- + -- @parseConfig@ is called on the object corresponding to the server's + -- config section, it should not itself try to look for the config section. + -- + -- Note that the 'J.Value' may represent only a partial object in the case where we + -- are handling a @workspace/didChangeConfiguration@ request where the client sends + -- only the changed settings. This is also the main circumstance where the old configuration + -- argument is useful. It is generally fine for servers to ignore this case and just + -- assume that the 'J.Value' represents a full new config and ignore the old configuration. + -- This will only be problematic in the case of clients which behave as above and *also* + -- don't support @workspace/configuration@, which is discouraged. + , onConfigChange :: config -> m () + -- ^ This callback is called any time the configuration is updated, with + -- 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 (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 + -- start new threads that may be necessary for the server lifecycle. It can + -- also return an error in the initialization if necessary. + , staticHandlers :: ClientCapabilities -> Handlers m + -- ^ Handlers for any methods you want to statically support. + -- The handlers here cannot be unregistered during the server's lifetime + -- and will be registered statically in the initialize request. + -- The handlers provided can depend on the client capabilities, which + -- are static across the lifetime of the server. + , interpretHandler :: a -> (m <~> IO) + -- ^ How to run the handlers in your own monad of choice, @m@. + -- It is passed the result of 'doInitialize', so typically you will want + -- to thread along the 'LanguageContextEnv' as well as any other state you + -- need to run your monad. @m@ should most likely be built on top of + -- 'LspT'. + -- + -- @ + -- ServerDefinition { ... + -- , doInitialize = \env _req -> pure $ Right env + -- , interpretHandler = \env -> Iso + -- (runLspT env) -- how to convert from IO ~> m + -- liftIO -- how to convert from m ~> IO + -- } + -- @ + , options :: Options + -- ^ Configurable options for the server's capabilities. + } + +{- | A function that a 'Handler' is passed that can be used to respond to a + request with either an error, or the response params. +-} +newtype ServerResponseCallback (m :: Method ServerToClient Request) + = 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 +-} +addResponseHandler :: MonadLsp config f => LspId m -> (Product SMethod ServerResponseCallback) m -> f Bool +addResponseHandler lid h = do + stateState resPendingResponses $ \pending -> + case insertIxMap lid h pending of + Just !m -> (True, m) + Nothing -> (False, pending) + +sendNotification :: + forall (m :: Method ServerToClient Notification) f config. + MonadLsp config f => + SServerMethod m -> + MessageParams m -> + f () +sendNotification m params = + let msg = TNotificationMessage "2.0" m params + in case splitServerMethod m of + IsServerNot -> sendToClient $ fromServerNot msg + IsServerEither -> sendToClient $ FromServerMess m $ NotMess msg + +sendRequest :: + forall (m :: Method ServerToClient Request) f config. + MonadLsp config f => + SServerMethod m -> + MessageParams m -> + (Either (TResponseError m) (MessageResult m) -> f ()) -> + f (LspId m) +sendRequest m params resHandler = do + reqId <- IdInt <$> freshLspId + rio <- askRunInIO + success <- addResponseHandler reqId (Pair m (ServerResponseCallback (rio . resHandler))) + unless success $ error "LSP: could not send FromServer request as id is reused" + + let msg = TRequestMessage "2.0" reqId m params + ~() <- case splitServerMethod m of + IsServerReq -> sendToClient $ fromServerReq msg + IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg + return reqId + +-- --------------------------------------------------------------------- + +-- | Return the 'VirtualFile' associated with a given 'NormalizedUri', if there is one. +getVirtualFile :: MonadLsp config m => NormalizedUri -> m (Maybe VirtualFile) +getVirtualFile uri = do + dat <- vfsData <$> getsState resVFS + pure $ dat ^? vfsMap . ix uri . _Open +{-# INLINE getVirtualFile #-} + +getVirtualFiles :: MonadLsp config m => m VFS +getVirtualFiles = vfsData <$> getsState resVFS +{-# INLINE getVirtualFiles #-} + +-- | Take an atomic snapshot of the current state of the virtual file system. +snapshotVirtualFiles :: LanguageContextEnv c -> STM VFS +snapshotVirtualFiles env = vfsData <$> readTVar (resVFS $ resState env) +{-# INLINE snapshotVirtualFiles #-} + +{- | Dump the current text for a given VFS file to a file + in the given directory and return the path to the file. +-} +persistVirtualFile :: MonadLsp config m => LogAction m (WithSeverity VfsLog) -> FilePath -> NormalizedUri -> m (Maybe FilePath) +persistVirtualFile logger dir uri = do + join $ stateState resVFS $ \vfs -> + case persistFileVFS logger dir (vfsData vfs) uri of + Nothing -> (return Nothing, vfs) + Just (fn, write) -> + let !revMap = case uriToFilePath (fromNormalizedUri uri) of + Just uri_fp -> Map.insert fn uri_fp $ reverseMap vfs + -- TODO: Does the VFS make sense for URIs which are not files? + -- The reverse map should perhaps be (FilePath -> URI) + Nothing -> reverseMap vfs + !vfs' = vfs{reverseMap = revMap} + act = do + write + pure (Just fn) + in (act, vfs') + +-- | Given a text document identifier, annotate it with the latest version. +getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier +getVersionedTextDoc doc = do + let uri = doc ^. L.uri + mvf <- getVirtualFile (toNormalizedUri uri) + let ver = case mvf of + Just (VirtualFile lspver _ _ _) -> lspver + Nothing -> 0 + return (VersionedTextDocumentIdentifier uri ver) +{-# INLINE getVersionedTextDoc #-} + +-- TODO: should this function return a URI? + +{- | If the contents of a VFS has been dumped to a temporary file, map + the temporary file name back to the original one. +-} +reverseFileMap :: MonadLsp config m => m (FilePath -> FilePath) +reverseFileMap = do + vfs <- getsState resVFS + let f fp = Map.findWithDefault fp fp $ reverseMap vfs + return f +{-# INLINE reverseFileMap #-} + +-- --------------------------------------------------------------------- + +sendToClient :: MonadLsp config m => FromServerMessage -> m () +sendToClient msg = do + f <- resSendMessage <$> getLspEnv + liftIO $ f msg +{-# INLINE sendToClient #-} + +-- --------------------------------------------------------------------- + +freshLspId :: MonadLsp config m => m Int32 +freshLspId = do + stateState resLspId $ \cur -> + let !next = cur + 1 in (cur, next) +{-# INLINE freshLspId #-} + +-- --------------------------------------------------------------------- + +{- | The current configuration from the client as set via the @initialize@ and + @workspace/didChangeConfiguration@ requests, as well as by calls to + 'setConfig'. +-} +getConfig :: MonadLsp config m => m config +getConfig = getsState resConfig +{-# INLINE getConfig #-} + +setConfig :: MonadLsp config m => config -> m () +setConfig config = stateState resConfig (const ((), config)) +{-# INLINE setConfig #-} + +getClientCapabilities :: MonadLsp config m => m L.ClientCapabilities +getClientCapabilities = resClientCapabilities <$> getLspEnv +{-# INLINE getClientCapabilities #-} + +getRootPath :: MonadLsp config m => m (Maybe FilePath) +getRootPath = resRootPath <$> getLspEnv +{-# INLINE getRootPath #-} + +-- | The current workspace folders, if the client supports workspace folders. +getWorkspaceFolders :: MonadLsp config m => m (Maybe [WorkspaceFolder]) +getWorkspaceFolders = do + clientCaps <- getClientCapabilities + let clientSupportsWfs = fromMaybe False $ clientCaps ^? L.workspace . _Just . L.workspaceFolders . _Just + if clientSupportsWfs + then Just <$> getsState resWorkspaceFolders + else pure Nothing +{-# INLINE getWorkspaceFolders #-} + +{- | Sends a @client/registerCapability@ request and dynamically registers + a 'Method' with a 'Handler'. Returns 'Nothing' if the client does not + support dynamic registration for the specified method, otherwise a + 'RegistrationToken' which can be used to unregister it later. +-} +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 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 alreadyStaticallyRegistered + where + -- If the server has already registered statically, don't dynamically register + -- as per the spec + 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)) + in SMethodMap.insert method pair oldRegs + IsClientReq -> modifyState resRegistrationsReq $ \oldRegs -> + let pair = Pair regId (ClientMessageHandler (\msg k -> unliftIO rio $ f msg (liftIO . k))) + in SMethodMap.insert method pair oldRegs + IsClientEither -> error "Cannot register capability for custom methods" + + pure $ Just token + Nothing -> 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. +-} +unregisterCapability :: MonadLsp config f => RegistrationToken m -> f () +unregisterCapability (RegistrationToken m (RegistrationId uuid)) = do + ~() <- case splitClientMethod m of + IsClientReq -> modifyState resRegistrationsReq $ SMethodMap.delete m + IsClientNot -> modifyState resRegistrationsNot $ SMethodMap.delete m + IsClientEither -> error "Cannot unregister capability for custom methods" + + let unregistration = L.TUnregistration uuid m + params = L.UnregistrationParams [toUntypedUnregistration unregistration] + void $ sendRequest SMethod_ClientUnregisterCapability params $ \_res -> pure () + +-- --------------------------------------------------------------------- + +{- | Aggregate all diagnostics pertaining to a particular version of a document, + by source, and sends a @textDocument/publishDiagnostics@ notification with + the total (limited by the first parameter) whenever it is updated. +-} +publishDiagnostics :: MonadLsp config m => Int -> NormalizedUri -> Maybe L.Int32 -> DiagnosticsBySource -> m () +publishDiagnostics maxDiagnosticCount uri version diags = join $ stateState resDiagnostics $ \oldDiags -> + let !newDiags = updateDiagnostics oldDiags uri version diags + mdp = getDiagnosticParamsFor maxDiagnosticCount newDiags uri + act = case mdp of + Nothing -> return () + Just params -> + sendToClient $ L.fromServerNot $ L.TNotificationMessage "2.0" L.SMethod_TextDocumentPublishDiagnostics params + in (act, newDiags) + +-- --------------------------------------------------------------------- + +{- | Remove all diagnostics from a particular source, and send the updates to + the client. +-} +flushDiagnosticsBySource :: + MonadLsp config m => + -- | Max number of diagnostics to send + Int -> + Maybe Text -> + m () +flushDiagnosticsBySource maxDiagnosticCount msource = join $ stateState resDiagnostics $ \oldDiags -> + let !newDiags = flushBySource oldDiags msource + -- 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) + +-- --------------------------------------------------------------------- + +{- | 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. +-} +reverseSortEdit :: L.WorkspaceEdit -> L.WorkspaceEdit +reverseSortEdit (L.WorkspaceEdit cs dcs anns) = L.WorkspaceEdit cs' dcs' anns + where + cs' :: Maybe (Map.Map Uri [TextEdit]) + cs' = (fmap . fmap) sortTextEdits cs + + dcs' :: Maybe [L.DocumentChange] + dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs + + sortTextEdits :: [L.TextEdit] -> [L.TextEdit] + sortTextEdits edits = L.sortOn (Down . (^. L.range)) edits + + sortOnlyTextDocumentEdits :: L.DocumentChange -> L.DocumentChange + sortOnlyTextDocumentEdits (L.InL (L.TextDocumentEdit td edits)) = L.InL $ L.TextDocumentEdit td edits' + where + edits' = L.sortOn (Down . editRange) edits + sortOnlyTextDocumentEdits (L.InR others) = L.InR others + + editRange :: L.TextEdit L.|? L.AnnotatedTextEdit -> L.Range + editRange (L.InR e) = e ^. L.range + editRange (L.InL e) = e ^. L.range + +-------------------------------------------------------------------------------- +-- CONFIG +-------------------------------------------------------------------------------- + +-- | Given a new config object, try to update our config with it. +tryChangeConfig :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) -> J.Value -> m () +tryChangeConfig logger newConfigObject = do + parseCfg <- LspT $ asks resParseConfig + res <- stateState resConfig $ \oldConfig -> case parseCfg oldConfig newConfigObject of + Left err -> (Left err, oldConfig) + Right newConfig -> (Right newConfig, newConfig) + case res of + Left err -> do + logger <& ConfigurationParseError newConfigObject err `WithSeverity` Warning + Right newConfig -> do + logger <& NewConfig newConfigObject `WithSeverity` Debug + cb <- LspT $ asks resOnConfigChange + liftIO $ cb newConfig + +{- | Send a `worksapce/configuration` request to update the server's config. + + This is called automatically in response to `workspace/didChangeConfiguration` notifications + from the client, so should not normally be called manually. +-} +requestConfigUpdate :: (m ~ LspM config) => LogAction m (WithSeverity LspCoreLog) -> m () +requestConfigUpdate logger = do + caps <- LspT $ asks resClientCapabilities + let supportsConfiguration = fromMaybe False $ caps ^? L.workspace . _Just . L.configuration . _Just + if supportsConfiguration + then do + section <- LspT $ asks resConfigSection + void $ sendRequest SMethod_WorkspaceConfiguration (ConfigurationParams [ConfigurationItem Nothing (Just section)]) $ \case + Right [newConfigObject] -> tryChangeConfig logger newConfigObject + Right sections -> logger <& WrongConfigSections sections `WithSeverity` Error + 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 +- Many of the configuration messages are not specified in what they should return + +In particular, configuration appears in three places: +1. The `initializationOptions` field of the `initialize` request. + - The contents of this are unspecified. "User provided initialization options". +2. The `settings` field of the `workspace/didChangeConfiguration` notification. + - The contents of this are unspecified. "The actual changed settings". +3. The `section` field of the response to the `workspace/configuration` request. + - This at least says it should be the settings corresponding to the sections + specified in the request. + +It's very hard to know what to do here. In particular, the first two cases seem +like they could include arbitrary configuration from the client that might not +relate to you. How you locate "your" settings is unclear. + +We are on firmer ground with case 3. Then at least it seems that we can pick +a configuration section, just always ask for that, and require clients to use +that for our settings. Furthermore, this is the method that is encouraged by the +specification designers: https://github.com/microsoft/language-server-protocol/issues/567#issuecomment-420589320. + +For this reason we mostly try and rely on `workspace/configuration`. That means +three things: +- We require servers to give a specific configuration section for us to use + when requesting configuration. +- We can try and make sense of `initializationOptions`, but regardless we should + send a `workspace/configuration` request afterwards (in the handler for the + `initialized` notification, which is the earliest we can send messages: + https://github.com/microsoft/language-server-protocol/issues/567#issuecomment-953772465) +- We can try and make sense of `didChangeConfiguration`, but regardless we should + send a `workspace/configuration` request afterwards + +We do try to make sense of the first two cases also, especially because clients do +not have to support `workspace/configuration`! In practice, +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 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,397 +1,579 @@ -{-# LANGUAGE TypeInType #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} - +-- there's just so much! +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} --- So we can keep using the old prettyprinter modules (which have a better --- compatibility range) for now. -{-# OPTIONS_GHC -Wno-deprecations #-} module Language.LSP.Server.Processing where -import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) +import Colog.Core ( + LogAction (..), + Severity (..), + WithSeverity (..), + cmap, + (<&), + ) -import Control.Lens hiding (List, Empty) -import Data.Aeson hiding (Options, Error) -import Data.Aeson.Types hiding (Options, Error) -import qualified Data.ByteString.Lazy as BSL -import Data.List -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Text as T -import qualified Data.Text.Lazy.Encoding as TL -import Language.LSP.Types -import Language.LSP.Types.Capabilities -import qualified Language.LSP.Types.Lens as LSP -import Language.LSP.Types.SMethodMap (SMethodMap) -import qualified Language.LSP.Types.SMethodMap as SMethodMap -import Language.LSP.Server.Core -import Language.LSP.VFS as VFS -import qualified Data.Functor.Product as P -import qualified Control.Exception as E -import Data.Monoid +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.Except () -import Control.Concurrent.STM -import Control.Monad.Trans.Except +import Control.Monad.IO.Class import Control.Monad.Reader -import Data.IxMap -import Data.Maybe -import qualified Data.Map.Strict as Map -import Data.Text.Prettyprint.Doc -import System.Exit -import Data.Default (def) import Control.Monad.State -import Control.Monad.Writer.Strict +import Control.Monad.Trans.Except +import Control.Monad.Writer.Strict +import Data.Aeson hiding ( + Error, + Null, + Options, + ) +import Data.Aeson qualified as J +import Data.Aeson.Lens () +import Data.Aeson.Types hiding ( + Error, + Null, + Options, + ) +import Data.ByteString.Lazy qualified as BSL import Data.Foldable (traverse_) +import Data.Functor.Product qualified as P +import Data.IxMap +import Data.List +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Monoid +import Data.String (fromString) +import Data.Text qualified as T +import Data.Text.Lazy.Encoding qualified as TL +import Language.LSP.Protocol.Lens qualified as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap) +import Language.LSP.Protocol.Utils.SMethodMap qualified as SMethodMap +import Language.LSP.Server.Core +import Language.LSP.VFS as VFS +import Prettyprinter -data LspProcessingLog = - VfsLog VfsLog +data LspProcessingLog + = VfsLog VfsLog + | LspCore LspCoreLog | MessageProcessingError BSL.ByteString String - | forall m . MissingHandler Bool (SClientMethod m) - | ConfigurationParseError Value T.Text + | forall m. MissingHandler Bool (SClientMethod m) | ProgressCancel ProgressToken + | forall m. MessageDuringShutdown (SClientMethod m) + | ShuttingDown | Exiting deriving instance Show LspProcessingLog instance Pretty LspProcessingLog where pretty (VfsLog l) = pretty l + pretty (LspCore l) = pretty l pretty (MessageProcessingError bs err) = - vsep [ - "LSP: incoming message parse error:" + vsep + [ "LSP: incoming message parse error:" , pretty err , "when processing" , pretty (TL.decodeUtf8 bs) ] - pretty (MissingHandler _ m) = "LSP: no handler for:" <+> viaShow m - pretty (ConfigurationParseError settings err) = - vsep [ - "LSP: configuration parse error:" - , pretty err - , "when parsing" - , viaShow settings - ] - pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> viaShow tid - pretty Exiting = "LSP: Got exit, exiting" + pretty (MissingHandler _ m) = "LSP: no handler for:" <+> pretty m + pretty (ProgressCancel tid) = "LSP: cancelling action for token:" <+> pretty tid + 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 - msg <- except $ parseEither (parser pending) val - lift $ case msg of - FromClientMess m mess -> - pure $ handle logger m mess - FromClientRsp (P.Pair (ServerResponseCallback f) (Const !newMap)) res -> do - writeTVar pendingResponsesVar newMap - pure $ liftIO $ f (res ^. LSP.result) - where - parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap))) - parser rm = parseClientMessage $ \i -> - let (mhandler, newMap) = pickFromIxMap i rm - in (\(P.Pair m handler) -> (m,P.Pair handler (Const newMap))) <$> mhandler + val <- except $ eitherDecode jsonStr + pending <- lift $ readTVar pendingResponsesVar + msg <- except $ parseEither (parser pending) val + lift $ case msg of + FromClientMess m mess -> + pure $ handle logger m mess + FromClientRsp (P.Pair (ServerResponseCallback f) (Const !newMap)) res -> do + -- see Note [Shutdown] + writeTVar pendingResponsesVar newMap + unless shutdown <$> do + pure $ liftIO $ f (res ^. L.result) + where + parser :: ResponseMap -> Value -> Parser (FromClientMessage' (P.Product ServerResponseCallback (Const ResponseMap))) + parser rm = parseClientMessage $ \i -> + let (mhandler, newMap) = pickFromIxMap i rm + in (\(P.Pair m handler) -> (m, P.Pair handler (Const newMap))) <$> mhandler - handleErrors = either (\e -> logger <& MessageProcessingError jsonStr e `WithSeverity` Error) id + handleErrors = either (\e -> logger <& MessageProcessingError jsonStr e `WithSeverity` Error) id -- | Call this to initialize the session -initializeRequestHandler - :: ServerDefinition config - -> VFS - -> (FromServerMessage -> IO ()) - -> Message Initialize - -> IO (Maybe (LanguageContextEnv config)) -initializeRequestHandler ServerDefinition{..} vfs sendFunc req = do - let sendResp = sendFunc . FromServerRsp SInitialize +initializeRequestHandler :: + LogAction IO (WithSeverity LspProcessingLog) -> + 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 waitSender req = do + let sendResp = sendFunc . FromServerRsp SMethod_Initialize handleErr (Left err) = do - sendResp $ makeResponseError (req ^. LSP.id) err + sendResp $ makeResponseError (req ^. L.id) err pure Nothing handleErr (Right a) = pure $ Just a - flip E.catch (initializeErrorHandler $ sendResp . makeResponseError (req ^. LSP.id)) $ handleErr <=< runExceptT $ mdo + E.handle (initializeErrorHandler $ sendResp . makeResponseError (req ^. L.id)) $ handleErr <=< runExceptT $ mdo + let p = req ^. L.params + rootDir = + getFirst $ + foldMap + First + [ p ^? L.rootUri . _L >>= uriToFilePath + , p ^? L.rootPath . _Just . _L <&> T.unpack + ] + clientCaps = p ^. L.capabilities - let params = req ^. LSP.params - rootDir = getFirst $ foldMap First [ params ^. LSP.rootUri >>= uriToFilePath - , params ^. LSP.rootPath <&> T.unpack ] + let initialWfs = case p ^. L.workspaceFolders of + Just (InL xs) -> xs + _ -> [] - let initialWfs = case params ^. LSP.workspaceFolders of - Just (List xs) -> xs - Nothing -> [] + -- See Note [LSP configuration] + configObject = lookForConfigSection configSection <$> (p ^. L.initializationOptions) - initialConfig = case onConfigurationChange defaultConfig <$> (req ^. LSP.params . LSP.initializationOptions) of - Just (Right newConfig) -> newConfig - _ -> defaultConfig + 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 + pure newConfig + Left err -> do + -- Warn not error here, since initializationOptions is pretty unspecified + liftIO $ logger <& LspCore (ConfigurationParseError o err) `WithSeverity` Warning + pure defaultConfig stateVars <- liftIO $ do - resVFS <- newTVarIO (VFSData vfs mempty) - resDiagnostics <- newTVarIO mempty - resConfig <- newTVarIO initialConfig + resVFS <- newTVarIO (VFSData vfs mempty) + resDiagnostics <- newTVarIO mempty + resConfig <- newTVarIO initialConfig resWorkspaceFolders <- newTVarIO initialWfs - resProgressData <- do + resProgressData <- do progressNextId <- newTVarIO 0 progressCancel <- newTVarIO mempty pure ProgressData{..} resPendingResponses <- newTVarIO emptyIxMap resRegistrationsNot <- newTVarIO mempty resRegistrationsReq <- newTVarIO mempty - resLspId <- newTVarIO 0 + 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 onConfigurationChange sendFunc stateVars (params ^. LSP.capabilities) rootDir - handlers = transmuteHandlers interpreter staticHandlers + 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 initializationResult <- ExceptT $ doInitialize env req - let serverCaps = inferServerCapabilities (params ^. LSP.capabilities) options handlers - liftIO $ sendResp $ makeResponseMessage (req ^. LSP.id) (InitializeResult serverCaps (serverInfo options)) + let serverCaps = inferServerCapabilities clientCaps options handlers + liftIO $ sendResp $ makeResponseMessage (req ^. L.id) (InitializeResult serverCaps (optServerInfo options)) pure env - where - makeResponseMessage rid result = ResponseMessage "2.0" (Just rid) (Right result) - makeResponseError origId err = ResponseMessage "2.0" (Just origId) (Left err) - - initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a) - initializeErrorHandler sendResp e = do - sendResp $ ResponseError InternalError msg Nothing - pure Nothing - where - msg = T.pack $ unwords ["Error on initialize:", show e] + where + makeResponseMessage rid result = TResponseMessage "2.0" (Just rid) (Right result) + makeResponseError origId err = TResponseMessage "2.0" (Just origId) (Left err) + initializeErrorHandler :: (TResponseError Method_Initialize -> IO ()) -> E.SomeException -> IO (Maybe a) + initializeErrorHandler sendResp e = do + sendResp $ TResponseError (InR ErrorCodes_InternalError) msg Nothing + pure Nothing + where + msg = T.pack $ unwords ["Error on initialize:", show e] --- | Infers the capabilities based on registered handlers, and sets the appropriate options. --- A provider should be set to Nothing if the server does not support it, unless it is a --- static option. +{- | Infers the capabilities based on registered handlers, and sets the appropriate options. + A provider should be set to Nothing if the server does not support it, unless it is a + static option. +-} inferServerCapabilities :: ClientCapabilities -> Options -> Handlers m -> ServerCapabilities -inferServerCapabilities clientCaps o h = +inferServerCapabilities _clientCaps o h = ServerCapabilities - { _textDocumentSync = sync - , _hoverProvider = supportedBool STextDocumentHover - , _completionProvider = completionProvider - , _declarationProvider = supportedBool STextDocumentDeclaration - , _signatureHelpProvider = signatureHelpProvider - , _definitionProvider = supportedBool STextDocumentDefinition - , _typeDefinitionProvider = supportedBool STextDocumentTypeDefinition - , _implementationProvider = supportedBool STextDocumentImplementation - , _referencesProvider = supportedBool STextDocumentReferences - , _documentHighlightProvider = supportedBool STextDocumentDocumentHighlight - , _documentSymbolProvider = supportedBool STextDocumentDocumentSymbol - , _codeActionProvider = codeActionProvider - , _codeLensProvider = supported' STextDocumentCodeLens $ CodeLensOptions - (Just False) - (supported SCodeLensResolve) - , _documentFormattingProvider = supportedBool STextDocumentFormatting - , _documentRangeFormattingProvider = supportedBool STextDocumentRangeFormatting + { _textDocumentSync = sync + , _hoverProvider = + supported' SMethod_TextDocumentHover $ + InR $ + HoverOptions clientInitiatedProgress + , _completionProvider = completionProvider + , _inlayHintProvider = inlayProvider + , _declarationProvider = + supported' SMethod_TextDocumentDeclaration $ + InR $ + InL $ + DeclarationOptions clientInitiatedProgress + , _signatureHelpProvider = signatureHelpProvider + , _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 clientInitiatedProgress (supported SMethod_CodeLensResolve) + , _documentFormattingProvider = + supported' SMethod_TextDocumentFormatting $ + InR $ + DocumentFormattingOptions clientInitiatedProgress + , _documentRangeFormattingProvider = + supported' SMethod_TextDocumentRangeFormatting $ + InR $ + DocumentRangeFormattingOptions clientInitiatedProgress , _documentOnTypeFormattingProvider = documentOnTypeFormattingProvider - , _renameProvider = renameProvider - , _documentLinkProvider = supported' STextDocumentDocumentLink $ DocumentLinkOptions - (Just False) - (supported SDocumentLinkResolve) - , _colorProvider = supportedBool STextDocumentDocumentColor - , _foldingRangeProvider = supportedBool STextDocumentFoldingRange - , _executeCommandProvider = executeCommandProvider - , _selectionRangeProvider = supportedBool STextDocumentSelectionRange - , _callHierarchyProvider = supportedBool STextDocumentPrepareCallHierarchy - , _semanticTokensProvider = semanticTokensProvider - , _workspaceSymbolProvider = supportedBool SWorkspaceSymbol - , _workspace = Just workspace - -- TODO: Add something for experimental - , _experimental = Nothing :: Maybe Value + , _renameProvider = + supported' SMethod_TextDocumentRename $ + InR $ + RenameOptions clientInitiatedProgress (supported SMethod_TextDocumentPrepareRename) + , _documentLinkProvider = + supported' SMethod_TextDocumentDocumentLink $ + DocumentLinkOptions clientInitiatedProgress (supported SMethod_DocumentLinkResolve) + , _colorProvider = + supported' SMethod_TextDocumentDocumentColor $ + InR $ + InL $ + DocumentColorOptions clientInitiatedProgress + , _foldingRangeProvider = + supported' SMethod_TextDocumentFoldingRange $ + InR $ + InL $ + FoldingRangeOptions clientInitiatedProgress + , _executeCommandProvider = executeCommandProvider + , _selectionRangeProvider = + supported' SMethod_TextDocumentSelectionRange $ + InR $ + InL $ + SelectionRangeOptions clientInitiatedProgress + , _callHierarchyProvider = + supported' SMethod_TextDocumentPrepareCallHierarchy $ + InR $ + InL $ + CallHierarchyOptions clientInitiatedProgress + , _semanticTokensProvider = semanticTokensProvider + , _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 + _positionEncoding = Just PositionEncodingKind_UTF16 + , _linkedEditingRangeProvider = + supported' SMethod_TextDocumentLinkedEditingRange $ + InR $ + InL $ + LinkedEditingRangeOptions clientInitiatedProgress + , _monikerProvider = + supported' SMethod_TextDocumentMoniker $ + InR $ + InL $ + MonikerOptions clientInitiatedProgress + , _typeHierarchyProvider = + supported' SMethod_TextDocumentPrepareTypeHierarchy $ + InR $ + InL $ + TypeHierarchyOptions clientInitiatedProgress + , _inlineValueProvider = + supported' SMethod_TextDocumentInlineValue $ + InR $ + InL $ + 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 + where + clientInitiatedProgress = Just (optSupportClientInitiatedProgress o) - supported' m b - | supported_b m = Just b - | otherwise = Nothing + supported' m b + | supported_b m = Just b + | otherwise = Nothing - supported :: forall m. SClientMethod m -> Maybe Bool - supported = Just . supported_b + supported :: forall m. SClientMethod m -> Maybe Bool + supported = Just . supported_b - supported_b :: forall m. SClientMethod m -> Bool - supported_b m = case splitClientMethod m of - IsClientNot -> SMethodMap.member m $ notHandlers h - IsClientReq -> SMethodMap.member m $ reqHandlers h - IsClientEither -> error "capabilities depend on custom method" + supported_b :: forall m. SClientMethod m -> Bool + supported_b m = case splitClientMethod m of + IsClientNot -> SMethodMap.member m $ notHandlers h + IsClientReq -> SMethodMap.member m $ reqHandlers h + IsClientEither -> error "capabilities depend on custom method" - singleton :: a -> [a] - singleton x = [x] + singleton :: a -> [a] + singleton x = [x] - completionProvider - | supported_b STextDocumentCompletion = Just $ - CompletionOptions - Nothing - (map T.singleton <$> completionTriggerCharacters o) - (map T.singleton <$> completionAllCommitCharacters o) - (supported SCompletionItemResolve) - | otherwise = Nothing + 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 + } - clientSupportsCodeActionKinds = isJust $ - clientCaps ^? LSP.textDocument . _Just . LSP.codeAction . _Just . LSP.codeActionLiteralSupport + inlayProvider = + supported' SMethod_TextDocumentInlayHint $ + InR $ + InL + InlayHintOptions + { _workDoneProgress = clientInitiatedProgress + , _resolveProvider = supported SMethod_InlayHintResolve + } - codeActionProvider - | clientSupportsCodeActionKinds - , supported_b STextDocumentCodeAction = Just $ case codeActionKinds o of - Just ks -> InR $ CodeActionOptions Nothing (Just (List ks)) (supported SCodeLensResolve) - Nothing -> InL True - | supported_b STextDocumentCodeAction = Just (InL True) - | otherwise = Just (InL False) + codeActionProvider = + supported' SMethod_TextDocumentCodeAction $ + InR $ + CodeActionOptions + { _workDoneProgress = clientInitiatedProgress + , _codeActionKinds = optCodeActionKinds o + , _resolveProvider = supported SMethod_CodeActionResolve + } - signatureHelpProvider - | supported_b STextDocumentSignatureHelp = Just $ - SignatureHelpOptions - Nothing - (List . map T.singleton <$> signatureHelpTriggerCharacters o) - (List . map T.singleton <$> signatureHelpRetriggerCharacters o) - | otherwise = Nothing + signatureHelpProvider = + supported' SMethod_TextDocumentSignatureHelp $ + SignatureHelpOptions + clientInitiatedProgress + (map T.singleton <$> optSignatureHelpTriggerCharacters o) + (map T.singleton <$> optSignatureHelpRetriggerCharacters o) - documentOnTypeFormattingProvider - | supported_b STextDocumentOnTypeFormatting - , Just (first :| rest) <- documentOnTypeFormattingTriggerCharacters o = Just $ + documentOnTypeFormattingProvider + | supported_b SMethod_TextDocumentOnTypeFormatting + , Just (first :| rest) <- optDocumentOnTypeFormattingTriggerCharacters o = + Just $ DocumentOnTypeFormattingOptions (T.pack [first]) (Just (map (T.pack . singleton) rest)) - | supported_b STextDocumentOnTypeFormatting - , Nothing <- documentOnTypeFormattingTriggerCharacters o = - error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" - | otherwise = Nothing + | supported_b SMethod_TextDocumentOnTypeFormatting + , Nothing <- optDocumentOnTypeFormattingTriggerCharacters o = + error "documentOnTypeFormattingTriggerCharacters needs to be set if a documentOnTypeFormattingHandler is set" + | otherwise = Nothing - executeCommandProvider - | supported_b SWorkspaceExecuteCommand - , Just cmds <- executeCommandCommands o = Just (ExecuteCommandOptions Nothing (List cmds)) - | supported_b SWorkspaceExecuteCommand - , Nothing <- executeCommandCommands o = - error "executeCommandCommands needs to be set if a executeCommandHandler is set" - | otherwise = Nothing + 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" - clientSupportsPrepareRename = fromMaybe False $ - clientCaps ^? LSP.textDocument . _Just . LSP.rename . _Just . LSP.prepareSupport . _Just + -- Always provide the default legend + -- TODO: allow user-provided legend via 'Options', or at least user-provided types + 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 $ SemanticTokensFullDelta{_delta = supported SMethod_TextDocumentSemanticTokensFullDelta} + | otherwise = Nothing - renameProvider - | clientSupportsPrepareRename - , supported_b STextDocumentRename - , supported_b STextDocumentPrepareRename = Just $ - InR . RenameOptions Nothing . Just $ True - | supported_b STextDocumentRename = Just (InL True) - | otherwise = Just (InL False) + sync = case optTextDocumentSync o of + Just x -> Just (InL x) + Nothing -> Nothing - -- Always provide the default legend - -- TODO: allow user-provided legend via 'Options', or at least user-provided types - semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing def semanticTokenRangeProvider semanticTokenFullProvider - semanticTokenRangeProvider - | supported_b STextDocumentSemanticTokensRange = Just $ SemanticTokensRangeBool True - | otherwise = Nothing - semanticTokenFullProvider - | supported_b STextDocumentSemanticTokensFull = Just $ SemanticTokensFullDelta $ SemanticTokensDeltaClientCapabilities $ supported STextDocumentSemanticTokensFullDelta - | otherwise = Nothing + workspace = WorkspaceOptions{_workspaceFolders = workspaceFolder, _fileOperations = Just fileOperations} - sync = case textDocumentSync o of - Just x -> Just (InL x) - Nothing -> Nothing + workspaceFolder = + supported' SMethod_WorkspaceDidChangeWorkspaceFolders $ + -- sign up to receive notifications + WorkspaceFoldersServerCapabilities (Just True) (Just (InR True)) - workspace = WorkspaceServerCapabilities workspaceFolder - workspaceFolder = supported' SWorkspaceDidChangeWorkspaceFolders $ - -- 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 + } --- | 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 -> ClientMessage meth -> m () + diagnosticProvider = + supported' SMethod_TextDocumentDiagnostic $ + InL $ + DiagnosticOptions + { _workDoneProgress = clientInitiatedProgress + , _identifier = Nothing + , -- TODO: this is a conservative but maybe inaccurate, unclear how much it matters + _interFileDependencies = True + , _workspaceDiagnostics = supported_b SMethod_WorkspaceDiagnostic + } + +{- | Invokes the registered dynamic or static handlers for the given message and + method, as well as doing some bookkeeping. +-} +handle :: forall m config meth. (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m () handle logger m msg = case m of - SWorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg - SWorkspaceDidChangeConfiguration -> handle' logger (Just $ handleConfigChange logger) m msg - STextDocumentDidOpen -> handle' logger (Just $ vfsFunc logger openVFS) m msg - STextDocumentDidChange -> handle' logger (Just $ vfsFunc logger changeFromClientVFS) m msg - STextDocumentDidClose -> handle' logger (Just $ vfsFunc logger closeVFS) m msg - SWindowWorkDoneProgressCancel -> handle' logger (Just $ progressCancelHandler logger) m msg + 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 $ \_ -> 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 + SMethod_WindowWorkDoneProgressCancel -> handle' logger (Just $ progressCancelHandler logger) m msg _ -> handle' logger Nothing m msg - -handle' :: forall m t (meth :: Method FromClient t) config - . (m ~ LspM config) - => LogAction m (WithSeverity LspProcessingLog) - -> Maybe (ClientMessage meth -> m ()) - -- ^ An action to be run before invoking the handler, used for - -- bookkeeping stuff like the vfs etc. - -> SClientMethod meth - -> ClientMessage meth - -> m () +handle' :: + forall m t (meth :: Method ClientToServer t) config. + (m ~ LspM config) => + LogAction m (WithSeverity LspProcessingLog) -> + -- | An action to be run before invoking the handler, used for + -- bookkeeping stuff like the vfs etc. + Maybe (TClientMessage meth -> m ()) -> + SClientMethod meth -> + 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 :: RequestMessage (m1 :: Method FromClient Request) -> Either ResponseError (ResponseResult m1) -> IO () - mkRspCb req (Left err) = runLspT env $ sendToClient $ - FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.id)) (Left err) - mkRspCb req (Right rsp) = runLspT env $ sendToClient $ - FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.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 - | SExit <- m -> exitNotificationHandler logger msg - | otherwise -> do - reportMissingHandler - + | SMethod_Exit <- m -> exitNotificationHandler logger msg + | 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 - | SShutdown <- m -> liftIO $ shutdownRequestHandler msg (mkRspCb msg) - | otherwise -> do - let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] - err = ResponseError MethodNotFound errorMsg Nothing - sendToClient $ - FromServerRsp (msg ^. LSP.method) $ ResponseMessage "2.0" (Just (msg ^. LSP.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 MethodNotFound errorMsg Nothing - sendToClient $ - FromServerRsp (req ^. LSP.method) $ ResponseMessage "2.0" (Just (req ^. LSP.id)) (Left err) - where - -- | Checks to see if there's a dynamic handler, and uses it in favour of the - -- static handler, if it exists. - pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO meth) - pickHandler dynHandlerMap staticHandler = case (SMethodMap.lookup m dynHandlerMap, SMethodMap.lookup m staticHandler) of - (Just (P.Pair _ (ClientMessageHandler h)), _) -> Just h - (Nothing, Just (ClientMessageHandler h)) -> Just h - (Nothing, Nothing) -> Nothing + 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. + pickHandler :: RegistrationMap t -> SMethodMap (ClientMessageHandler IO t) -> Maybe (Handler IO meth) + pickHandler dynHandlerMap staticHandler = case (SMethodMap.lookup m dynHandlerMap, SMethodMap.lookup m staticHandler) of + (Just (P.Pair _ (ClientMessageHandler h)), _) -> Just h + (Nothing, Just (ClientMessageHandler h)) -> Just h + (Nothing, Nothing) -> Nothing - -- '$/' 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 = - let optional = isOptionalNotification m - in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error - isOptionalNotification (SCustomMethod method) - | "$/" `T.isPrefixOf` method = True - isOptionalNotification _ = False + 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 -progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Message WindowWorkDoneProgressCancel -> m () -progressCancelHandler logger (NotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do + 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. + 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) case Map.lookup tid pdata of Nothing -> return () @@ -399,34 +581,61 @@ logger <& ProgressCancel tid `WithSeverity` Debug liftIO cancelAction -exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Exit -exitNotificationHandler logger _ = do - logger <& Exiting `WithSeverity` Info - liftIO exitSuccess +exitNotificationHandler :: (MonadIO m) => LogAction m (WithSeverity LspProcessingLog) -> Handler m Method_Exit +exitNotificationHandler _logger _ = do + -- default exit handler do nothing + return () -- | Default Shutdown handler -shutdownRequestHandler :: Handler IO Shutdown +shutdownRequestHandler :: Handler IO Method_Shutdown shutdownRequestHandler _req k = do - k $ Right Empty + k $ Right Null -handleConfigChange :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> Message WorkspaceDidChangeConfiguration -> m () -handleConfigChange logger req = do - parseConfig <- LspT $ asks resParseConfig - let settings = req ^. LSP.params . LSP.settings - res <- stateState resConfig $ \oldConfig -> case parseConfig oldConfig settings of - Left err -> (Left err, oldConfig) - Right !newConfig -> (Right (), newConfig) - case res of - Left err -> do - logger <& ConfigurationParseError settings err `WithSeverity` Error - Right () -> pure () +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)) -vfsFunc :: forall m n a config - . (m ~ LspM config, n ~ WriterT [WithSeverity VfsLog] (State VFS)) - => LogAction m (WithSeverity LspProcessingLog) - -> (LogAction n (WithSeverity VfsLog) -> a -> n ()) - -> a - -> m () +{- | 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 + it. Otherwise we fall back to the whole object. + See Note [LSP configuration] +-} +lookForConfigSection :: T.Text -> Value -> Value +lookForConfigSection section (Object o) | Just s' <- o ^. at (fromString $ T.unpack section) = s' +lookForConfigSection _ o = o + +-- | Handle a workspace/didChangeConfiguration request. +handleDidChangeConfiguration :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WorkspaceDidChangeConfiguration -> m () +handleDidChangeConfiguration logger req = do + section <- LspT $ asks resConfigSection + -- See Note [LSP configuration] + + -- There are a few cases: + -- 1. Client supports `workspace/configuration` and sends nothing in `workspace/didChangeConfiguration` + -- Then we will fail the first attempt and succeed the second one. + -- 2. Client does not support `workspace/configuration` and sends updated config in `workspace/didChangeConfiguration`. + -- Then we will succeed the first attempt and fail (or in fact do nothing in) the second one. + -- 3. Client supports `workspace/configuration` and sends updated config in `workspace/didChangeConfiguration`. + -- Then both will succeed, which is a bit redundant but not a big deal. + tryChangeConfig (cmap (fmap LspCore) logger) (lookForConfigSection section $ req ^. L.params . L.settings) + requestConfigUpdate (cmap (fmap LspCore) logger) + +vfsFunc :: + forall m n a config. + (m ~ LspM config, n ~ WriterT [WithSeverity VfsLog] (State VFS)) => + LogAction m (WithSeverity LspProcessingLog) -> + (LogAction n (WithSeverity VfsLog) -> a -> n ()) -> + a -> + m () vfsFunc logger modifyVfs req = do -- This is an intricate dance. We want to run the VFS functions essentially in STM, that's -- what 'stateState' does. But we also want them to log. We accomplish this by exfiltrating @@ -436,17 +645,17 @@ -- DList here if we're worried about performance. logs <- stateState resVFS $ \(VFSData vfs rm) -> let (ls, vfs') = flip runState vfs $ execWriterT $ modifyVfs innerLogger req - in (ls, VFSData vfs' rm) + in (ls, VFSData vfs' rm) traverse_ (\l -> logger <& fmap VfsLog l) logs - where - innerLogger :: LogAction n (WithSeverity VfsLog) - innerLogger = LogAction $ \m -> tell [m] + where + innerLogger :: LogAction n (WithSeverity VfsLog) + innerLogger = LogAction $ \m -> tell [m] -- | Updates the list of workspace folders -updateWorkspaceFolders :: Message WorkspaceDidChangeWorkspaceFolders -> LspM config () -updateWorkspaceFolders (NotificationMessage _ _ params) = do - let List toRemove = params ^. LSP.event . LSP.removed - List toAdd = params ^. LSP.event . LSP.added +updateWorkspaceFolders :: TMessage Method_WorkspaceDidChangeWorkspaceFolders -> LspM config () +updateWorkspaceFolders (TNotificationMessage _ _ params) = do + let toRemove = params ^. L.event . L.removed + toAdd = params ^. L.event . L.added newWfs oldWfs = foldr delete oldWfs toRemove <> toAdd modifyState resWorkspaceFolders newWfs 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,118 +1,135 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeInType #-} - -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - --- So we can keep using the old prettyprinter modules (which have a better --- compatibility range) for now. -{-# OPTIONS_GHC -Wno-deprecations #-} +{-# LANGUAGE ViewPatterns #-} -{-| +{- | Handles the "Language.LSP.Types.TextDocumentDidChange" \/ "Language.LSP.Types.TextDocumentDidOpen" \/ "Language.LSP.Types.TextDocumentDidClose" messages to keep an in-memory `filesystem` of the current client workspace. The server can access and edit files in the client workspace by operating on the "VFS" in "LspFuncs". -} -module Language.LSP.VFS - ( - VFS(..) - , vfsMap - , vfsTempDir - , VirtualFile(..) - , lsp_version - , file_version - , file_text - , virtualFileText - , virtualFileVersion - , VfsLog (..) +module Language.LSP.VFS ( + VFS (..), + vfsMap, + VirtualFile (..), + ClosedVirtualFile (..), + VirtualFileEntry (..), + lsp_version, + file_version, + file_text, + language_id, + _Open, + _Closed, + virtualFileText, + virtualFileVersion, + virtualFileLanguageKind, + closedVirtualFileLanguageKind, + virtualFileEntryLanguageKind, + VfsLog (..), + -- * Managing the VFS - , initVFS - , openVFS - , changeFromClientVFS - , changeFromServerVFS - , persistFileVFS - , closeVFS + emptyVFS, + openVFS, + changeFromClientVFS, + changeFromServerVFS, + persistFileVFS, + closeVFS, -- * Positions and transformations - , CodePointPosition (..) - , line - , character - , codePointPositionToPosition - , positionToCodePointPosition - , CodePointRange (..) - , start - , end - , codePointRangeToRange - , rangeToCodePointRange + CodePointPosition (..), + line, + character, + codePointPositionToPosition, + positionToCodePointPosition, + CodePointRange (..), + start, + end, + codePointRangeToRange, + rangeToCodePointRange, -- * manipulating the file contents - , rangeLinesFromVfs - , PosPrefixInfo(..) - , getCompletionPrefix + rangeLinesFromVfs, -- * for tests - , applyChanges - , applyChange - , changeChars - ) where + applyChanges, + applyChange, + changeChars, +) where -import Control.Lens hiding ( (<.>), parts ) -import Control.Monad -import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&)) -import Control.Monad.State -import Data.Char (isUpper, isAlphaNum) -import Data.Text ( Text ) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Int (Int32) -import Data.List -import Data.Ord -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Map.Strict as Map -import Data.Maybe -import qualified Data.Text.Rope as URope -import Data.Text.Utf16.Rope ( Rope ) -import qualified Data.Text.Utf16.Rope as Rope -import Data.Text.Prettyprint.Doc hiding (line) -import qualified Language.LSP.Types as J -import qualified Language.LSP.Types.Lens as J -import System.FilePath -import Data.Hashable -import System.Directory -import System.IO -import System.IO.Temp +import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&)) +import Control.Lens hiding (parts, (<.>)) +import Control.Monad +import Control.Monad.State import Data.Foldable (traverse_) +import Data.Hashable +import Data.Int (Int32) +import Data.List +import Data.Map.Strict qualified as Map +import Data.Ord +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.IO qualified as T +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 -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} {-# ANN module ("hlint: ignore Redundant do" :: String) #-} + -- --------------------------------------------------------------------- -data VirtualFile = - VirtualFile { - _lsp_version :: !Int32 -- ^ The LSP version of the document - , _file_version :: !Int -- ^ This number is only incremented whilst the file - -- remains in the map. - , _file_text :: !Rope -- ^ The full contents of the document - } deriving (Show) +data VirtualFile = VirtualFile + { _lsp_version :: !Int32 + -- ^ The LSP version of the document + , _file_version :: !Int + -- ^ This number is only incremented whilst the file + -- 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) -data VFS = VFS { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile) - , _vfsTempDir :: !FilePath -- ^ This is where all the temporary files will be written to - } 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 VfsLog = - SplitInsideCodePoint Rope.Position Rope +data VirtualFileEntry = Open VirtualFile | Closed ClosedVirtualFile + deriving (Show) + +data VFS = VFS + { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFileEntry) + } + deriving (Show) + +data VfsLog + = SplitInsideCodePoint Utf16.Position Rope + | ApplyChangeToClosedFile J.NormalizedUri | URINotFound J.NormalizedUri | Opening J.NormalizedUri | Closing J.NormalizedUri @@ -124,16 +141,19 @@ instance Pretty VfsLog where pretty (SplitInsideCodePoint pos r) = "VFS: asked to make change inside code point. Position" <+> viaShow pos <+> "in" <+> viaShow r - pretty (URINotFound uri) = "VFS: don't know about URI" <+> viaShow uri - pretty (Opening uri) = "VFS: opening" <+> viaShow uri - pretty (Closing uri) = "VFS: closing" <+> viaShow uri - pretty (PersistingFile uri fp) = "VFS: Writing virtual file for" <+> viaShow uri <+> "to" <+> viaShow fp + 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 + pretty (PersistingFile uri fp) = "VFS: Writing virtual file for" <+> pretty uri <+> "to" <+> viaShow fp pretty (CantRecursiveDelete uri) = - "VFS: can't recursively delete" <+> viaShow uri <+> "because we don't track directory status" - pretty (DeleteNonExistent uri) = "VFS: asked to delete non-existent file" <+> viaShow uri + "VFS: can't recursively delete" <+> pretty uri <+> "because we don't track directory status" + pretty (DeleteNonExistent uri) = "VFS: asked to delete non-existent file" <+> pretty uri makeFieldsNoPrefix ''VirtualFile +makeFieldsNoPrefix ''ClosedVirtualFile makeFieldsNoPrefix ''VFS +makePrisms ''VirtualFileEntry --- @@ -143,89 +163,107 @@ 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 + } + --- -initVFS :: (VFS -> IO r) -> IO r -initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir) +emptyVFS :: VFS +emptyVFS = VFS mempty -- --------------------------------------------------------------------- -- | Applies the changes from a 'J.DidOpenTextDocument' to the 'VFS' -openVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidOpen -> m () +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) -- --------------------------------------------------------------------- -- | Applies a 'DidChangeTextDocumentNotification' to the 'VFS' -changeFromClientVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidChange -> m () +changeFromClientVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidChange -> m () changeFromClientVFS logger msg = do let - J.DidChangeTextDocumentParams vid (J.List changes) = msg ^. J.params + J.DidChangeTextDocumentParams vid changes = msg ^. J.params -- the client shouldn't be sending over a null version, only the server, but we just use 0 if that happens - J.VersionedTextDocumentIdentifier (J.toNormalizedUri -> uri) (fromMaybe 0 -> version) = vid + 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 -- --------------------------------------------------------------------- applyCreateFile :: (MonadState VFS m) => J.CreateFile -> m () -applyCreateFile (J.CreateFile (J.toNormalizedUri -> uri) options _ann) = - vfsMap %= Map.insertWith - (\ new old -> if shouldOverwrite then new else old) - uri - (VirtualFile 0 0 mempty) - where - shouldOverwrite :: Bool - shouldOverwrite = case options of - Nothing -> False -- default - Just (J.CreateFileOptions Nothing Nothing ) -> False -- default - Just (J.CreateFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True - Just (J.CreateFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False - Just (J.CreateFileOptions (Just True) Nothing ) -> True -- `overwrite` is True - Just (J.CreateFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists` - Just (J.CreateFileOptions (Just True) (Just False)) -> True -- `overwrite` is True - Just (J.CreateFileOptions (Just False) Nothing ) -> False -- `overwrite` is False - Just (J.CreateFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False - Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` +applyCreateFile (J.CreateFile _ann _kind (J.toNormalizedUri -> uri) options) = + vfsMap + %= Map.insertWith + (\new old -> if shouldOverwrite then new else old) + uri + (Open (VirtualFile 0 0 mempty Nothing)) + where + shouldOverwrite :: Bool + shouldOverwrite = case options of + Nothing -> False -- default + Just (J.CreateFileOptions Nothing Nothing) -> False -- default + Just (J.CreateFileOptions Nothing (Just True)) -> False -- `ignoreIfExists` is True + Just (J.CreateFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False + Just (J.CreateFileOptions (Just True) Nothing) -> True -- `overwrite` is True + Just (J.CreateFileOptions (Just True) (Just True)) -> True -- `overwrite` wins over `ignoreIfExists` + Just (J.CreateFileOptions (Just True) (Just False)) -> True -- `overwrite` is True + Just (J.CreateFileOptions (Just False) Nothing) -> False -- `overwrite` is False + Just (J.CreateFileOptions (Just False) (Just True)) -> False -- `overwrite` is False + Just (J.CreateFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` applyRenameFile :: (MonadState VFS m) => J.RenameFile -> m () -applyRenameFile (J.RenameFile (J.toNormalizedUri -> oldUri) (J.toNormalizedUri -> newUri) options _ann) = do +applyRenameFile (J.RenameFile _ann _kind (J.toNormalizedUri -> oldUri) (J.toNormalizedUri -> newUri) options) = do vfs <- get case vfs ^. vfsMap . at oldUri of - -- nothing to rename - Nothing -> pure () - Just file -> case vfs ^. vfsMap . at newUri of - -- the target does not exist, just move over - Nothing -> do - vfsMap . at oldUri .= Nothing - vfsMap . at newUri .= Just file - Just _ -> when shouldOverwrite $ do - vfsMap . at oldUri .= Nothing - vfsMap . at newUri .= Just file - where - shouldOverwrite :: Bool - shouldOverwrite = case options of - Nothing -> False -- default - Just (J.RenameFileOptions Nothing Nothing ) -> False -- default - Just (J.RenameFileOptions Nothing (Just True) ) -> False -- `ignoreIfExists` is True - Just (J.RenameFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False - Just (J.RenameFileOptions (Just True) Nothing ) -> True -- `overwrite` is True - Just (J.RenameFileOptions (Just True) (Just True) ) -> True -- `overwrite` wins over `ignoreIfExists` - Just (J.RenameFileOptions (Just True) (Just False)) -> True -- `overwrite` is True - Just (J.RenameFileOptions (Just False) Nothing ) -> False -- `overwrite` is False - Just (J.RenameFileOptions (Just False) (Just True) ) -> False -- `overwrite` is False - Just (J.RenameFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` + -- nothing to rename + Nothing -> pure () + Just file -> case vfs ^. vfsMap . at newUri of + -- the target does not exist, just move over + Nothing -> do + vfsMap . at oldUri .= Nothing + vfsMap . at newUri .= Just file + Just _ -> when shouldOverwrite $ do + vfsMap . at oldUri .= Nothing + vfsMap . at newUri .= Just file + where + shouldOverwrite :: Bool + shouldOverwrite = case options of + Nothing -> False -- default + Just (J.RenameFileOptions Nothing Nothing) -> False -- default + Just (J.RenameFileOptions Nothing (Just True)) -> False -- `ignoreIfExists` is True + Just (J.RenameFileOptions Nothing (Just False)) -> True -- `ignoreIfExists` is False + Just (J.RenameFileOptions (Just True) Nothing) -> True -- `overwrite` is True + Just (J.RenameFileOptions (Just True) (Just True)) -> True -- `overwrite` wins over `ignoreIfExists` + Just (J.RenameFileOptions (Just True) (Just False)) -> True -- `overwrite` is True + Just (J.RenameFileOptions (Just False) Nothing) -> False -- `overwrite` is False + Just (J.RenameFileOptions (Just False) (Just True)) -> False -- `overwrite` is False + Just (J.RenameFileOptions (Just False) (Just False)) -> False -- `overwrite` wins over `ignoreIfExists` applyDeleteFile :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.DeleteFile -> m () -applyDeleteFile logger (J.DeleteFile (J.toNormalizedUri -> uri) options _ann) = do +applyDeleteFile logger (J.DeleteFile _ann _kind (J.toNormalizedUri -> uri) options) = do -- NOTE: we are ignoring the `recursive` option here because we don't know which file is a directory when (options ^? _Just . J.recursive . _Just == Just True) $ logger <& CantRecursiveDelete uri `WithSeverity` Warning @@ -234,61 +272,64 @@ case old of -- It's not entirely clear what the semantics of 'ignoreIfNotExists' are, but if it -- doesn't exist and we're not ignoring it, let's at least log it. - Nothing | options ^? _Just . J.ignoreIfNotExists . _Just /= Just True -> - logger <& CantRecursiveDelete uri `WithSeverity` Warning + Nothing + | options ^? _Just . J.ignoreIfNotExists . _Just /= Just True -> + logger <& CantRecursiveDelete uri `WithSeverity` Warning _ -> pure () applyTextDocumentEdit :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TextDocumentEdit -> m () -applyTextDocumentEdit logger (J.TextDocumentEdit vid (J.List edits)) = do +applyTextDocumentEdit logger (J.TextDocumentEdit vid edits) = do -- all edits are supposed to be applied at once -- so apply from bottom up so they don't affect others let sortedEdits = sortOn (Down . editRange) edits changeEvents = map editToChangeEvent sortedEdits - ps = J.DidChangeTextDocumentParams vid (J.List changeEvents) - notif = J.NotificationMessage "" J.STextDocumentDidChange ps + -- TODO: is this right? + vid' = J.VersionedTextDocumentIdentifier (vid ^. J.uri) (case vid ^. J.version of J.InL v -> v; J.InR _ -> 0) + ps = J.DidChangeTextDocumentParams vid' changeEvents + notif = J.TNotificationMessage "" J.SMethod_TextDocumentDidChange ps changeFromClientVFS logger notif - - where - editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range - editRange (J.InR e) = e ^. J.range - editRange (J.InL e) = e ^. J.range + where + editRange :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.Range + editRange (J.InR e) = e ^. J.range + editRange (J.InL e) = e ^. J.range - editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent - editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText) - editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent (Just $ e ^. J.range) Nothing (e ^. J.newText) + editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent + 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 -applyDocumentChange _ (J.InR (J.InL change)) = applyCreateFile change -applyDocumentChange _ (J.InR (J.InR (J.InL change))) = applyRenameFile change +applyDocumentChange logger (J.InL change) = applyTextDocumentEdit logger change +applyDocumentChange _ (J.InR (J.InL change)) = applyCreateFile change +applyDocumentChange _ (J.InR (J.InR (J.InL change))) = applyRenameFile change applyDocumentChange logger (J.InR (J.InR (J.InR change))) = applyDeleteFile logger change -- | Applies the changes from a 'ApplyWorkspaceEditRequest' to the 'VFS' -changeFromServerVFS :: forall m . MonadState VFS m => LogAction m (WithSeverity VfsLog) -> J.Message 'J.WorkspaceApplyEdit -> m () +changeFromServerVFS :: forall m. MonadState VFS m => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_WorkspaceApplyEdit -> m () changeFromServerVFS logger msg = do let J.ApplyWorkspaceEditParams _label edit = msg ^. J.params J.WorkspaceEdit mChanges mDocChanges _anns = edit case mDocChanges of - Just (J.List docChanges) -> applyDocumentChanges docChanges + Just docChanges -> applyDocumentChanges docChanges Nothing -> case mChanges of - Just cs -> applyDocumentChanges $ map J.InL $ HashMap.foldlWithKey' changeToTextDocumentEdit [] cs + Just cs -> applyDocumentChanges $ map J.InL $ Map.foldlWithKey' changeToTextDocumentEdit [] cs Nothing -> pure () - - where - changeToTextDocumentEdit acc uri edits = - acc ++ [J.TextDocumentEdit (J.VersionedTextDocumentIdentifier uri (Just 0)) (fmap J.InL edits)] + where + changeToTextDocumentEdit acc uri edits = + acc ++ [J.TextDocumentEdit (J.OptionalVersionedTextDocumentIdentifier uri (J.InL 0)) (fmap J.InL edits)] - applyDocumentChanges :: [J.DocumentChange] -> m () - applyDocumentChanges = traverse_ (applyDocumentChange logger) . sortOn project + applyDocumentChanges :: [J.DocumentChange] -> m () + applyDocumentChanges = traverse_ (applyDocumentChange logger) . sortOn project - -- for sorting [DocumentChange] - project :: J.DocumentChange -> J.TextDocumentVersion -- type TextDocumentVersion = Maybe Int - project (J.InL textDocumentEdit) = textDocumentEdit ^. J.textDocument . J.version - project _ = Nothing + -- for sorting [DocumentChange] + project :: J.DocumentChange -> Maybe J.Int32 + project (J.InL textDocumentEdit) = case textDocumentEdit ^. J.textDocument . J.version of + J.InL v -> Just v + _ -> Nothing + project _ = Nothing -- --------------------------------------------------------------------- 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 @@ -297,85 +338,99 @@ padLeft :: Int -> Int -> String padLeft n num = let numString = show num - in replicate (n - length numString) '0' ++ numString - in prefix basename ++ "-" ++ padLeft 5 file_ver ++ "-" ++ show (hash uri_raw) <.> takeExtensions basename + in replicate (n - length numString) '0' ++ numString + in prefix basename ++ "-" ++ padLeft 5 file_ver ++ "-" ++ show (hash uri_raw) <.> takeExtensions basename --- | Write a virtual file to a temporary file if it exists in the VFS. -persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ()) -persistFileVFS logger vfs uri = +-- | Write a virtual file to a file in the given directory if it exists in the VFS. +persistFileVFS :: (MonadIO m) => LogAction m (WithSeverity VfsLog) -> FilePath -> VFS -> J.NormalizedUri -> Maybe (FilePath, m ()) +persistFileVFS logger dir vfs uri = case vfs ^. vfsMap . at uri of Nothing -> Nothing - Just vf -> - let tfn = virtualFileName (vfs ^. vfsTempDir) uri vf + (Just (Closed _)) -> Nothing + (Just (Open vf)) -> + let tfn = virtualFileName dir uri vf action = do exists <- liftIO $ doesFileExist tfn unless exists $ do - let contents = Rope.toText (_file_text vf) - writeRaw h = do + let contents = Rope.toText (_file_text vf) + writeRaw h = do -- We honour original file line endings hSetNewlineMode h noNewlineTranslation hSetEncoding h utf8 T.hPutStr h contents - logger <& PersistingFile uri tfn `WithSeverity` Debug - liftIO $ withFile tfn WriteMode writeRaw - in Just (tfn, action) + logger <& PersistingFile uri tfn `WithSeverity` Debug + liftIO $ withFile tfn WriteMode writeRaw + in Just (tfn, action) -- --------------------------------------------------------------------- -closeVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.Message 'J.TextDocumentDidClose -> m () +closeVFS :: (MonadState VFS m) => LogAction m (WithSeverity VfsLog) -> J.TMessage 'J.Method_TextDocumentDidClose -> m () 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 + ) -- --------------------------------------------------------------------- --- | Apply the list of changes. --- Changes should be applied in the order that they are --- received from the client. +{- | Apply the list of changes. + Changes should be applied in the order that they are + received from the client. +-} applyChanges :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> [J.TextDocumentContentChangeEvent] -> m Rope applyChanges logger = foldM (applyChange logger) -- --------------------------------------------------------------------- applyChange :: (Monad m) => LogAction m (WithSeverity VfsLog) -> Rope -> J.TextDocumentContentChangeEvent -> m Rope -applyChange _ _ (J.TextDocumentContentChangeEvent Nothing _ str) - = pure $ Rope.fromText str -applyChange logger str (J.TextDocumentContentChangeEvent (Just (J.Range (J.Position sl sc) (J.Position fl fc))) _ txt) - = changeChars logger str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt +applyChange logger str (J.TextDocumentContentChangeEvent (J.InL e)) + | 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 ^. J.text -- --------------------------------------------------------------------- --- | Given a 'Rope', start and end positions, and some new text, replace --- 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 +{- | Given a 'Rope', start and end positions, and some new text, replace + 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 -> Utf16.Position -> Utf16.Position -> Text -> m Rope changeChars logger str start finish new = do - case Rope.splitAtPosition finish str of - Nothing -> logger <& SplitInsideCodePoint finish str `WithSeverity` Warning >> pure str - Just (before, after) -> case Rope.splitAtPosition start before of - Nothing -> logger <& SplitInsideCodePoint start before `WithSeverity` Warning >> pure str - Just (before', _) -> pure $ mconcat [before', Rope.fromText new, after] + case Rope.utf16SplitAtPosition finish str of + Nothing -> logger <& SplitInsideCodePoint finish str `WithSeverity` Warning >> pure str + 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] -- --------------------------------------------------------------------- --- | A position, like a 'J.Position', but where the offsets in the line are measured in --- Unicode code points instead of UTF-16 code units. -data CodePointPosition = - CodePointPosition - { -- | Line position in a document (zero-based). - _line :: J.UInt - -- | Character offset on a line in a document in *code points* (zero-based). - , _character :: J.UInt - } deriving (Show, Read, Eq, Ord) +{- | A position, like a 'J.Position', but where the offsets in the line are measured in + Unicode code points instead of UTF-16 code units. +-} +data CodePointPosition = CodePointPosition + { _line :: J.UInt + -- ^ Line position in a document (zero-based). + , _character :: J.UInt + -- ^ Character offset on a line in a document in *code points* (zero-based). + } + deriving (Show, Read, Eq, Ord) --- | A range, like a 'J.Range', but where the offsets in the line are measured in --- Unicode code points instead of UTF-16 code units. -data CodePointRange = - CodePointRange - { _start :: CodePointPosition -- ^ The range's start position. - , _end :: CodePointPosition -- ^ The range's end position. - } deriving (Show, Read, Eq, Ord) +{- | A range, like a 'J.Range', but where the offsets in the line are measured in + Unicode code points instead of UTF-16 code units. +-} +data CodePointRange = CodePointRange + { _start :: CodePointPosition + -- ^ The range's start position. + , _end :: CodePointPosition + -- ^ The range's end position. + } + deriving (Show, Read, Eq, Ord) makeFieldsNoPrefix ''CodePointPosition makeFieldsNoPrefix ''CodePointRange @@ -387,155 +442,83 @@ - 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'. --- Logarithmic in the number of lines. +{- | Extracts a specific line from a 'Rope.Rope'. + Logarithmic in the number of lines. +-} 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 +{- | Given a virtual file, translate a 'CodePointPosition' in that file into a 'J.Position' in that file. --- | 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 + Will return 'Nothing' if the requested position is out of bounds of the document. --- | 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. --- --- Logarithmic in the number of lines in the document, and linear in the length of the line containing --- the position. + Logarithmic in the number of lines in the document, and linear in the length of the line containing + 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 + lineRope <- extractLine text $ fromIntegral l + guard $ c <= fromIntegral (Rope.charLength lineRope) + return $ J.Position l (fromIntegral $ Rope.utf16Length $ fst $ Rope.charSplitAt (fromIntegral c) lineRope) - cuc <- codePointOffsetToCodeUnitOffset utfLine (fromIntegral cpc) - pure $ J.Position l (fromIntegral cuc) +{- | Given a virtual file, translate a 'CodePointRange' in that file into a 'J.Range' in that file. --- | Given a virtual file, translate a 'CodePointRange' in that file into a 'J.Range' in that file. --- --- Will return 'Nothing' if any of the positions are out of bounds of the document. --- --- Logarithmic in the number of lines in the document, and linear in the length of the lines containing --- the positions. + Will return 'Nothing' if any of the positions are out of bounds of the document. + + Logarithmic in the number of lines in the document, and linear in the length of the lines containing + the positions. +-} codePointRangeToRange :: VirtualFile -> CodePointRange -> Maybe J.Range codePointRangeToRange vFile (CodePointRange b e) = J.Range <$> codePointPositionToPosition vFile b <*> codePointPositionToPosition vFile e --- | Given a virtual file, translate a 'J.Position' in that file into a 'CodePointPosition' in that file. --- --- Will return 'Nothing' if the requested position lies inside a code point, or if it is out of bounds of the document. --- --- Logarithmic in the number of lines in the document, and linear in the length of the line containing --- the position. +{- | Given a virtual file, translate a 'J.Position' in that file into a 'CodePointPosition' in that file. + + Will return 'Nothing' if the requested position lies inside a code point, or if it is out of bounds of the document. + + Logarithmic in the number of lines in the document, and linear in the length of the line containing + 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) + lineRope <- extractLine text $ fromIntegral l + guard $ c <= fromIntegral (Rope.utf16Length lineRope) + CodePointPosition l . fromIntegral . Rope.charLength . fst <$> Rope.utf16SplitAt (fromIntegral c) lineRope - cpc <- codeUnitOffsetToCodePointOffset utf16Line (fromIntegral cuc) - pure $ CodePointPosition l (fromIntegral cpc) +{- | Given a virtual file, translate a 'J.Range' in that file into a 'CodePointRange' in that file. --- | Given a virtual file, translate a 'J.Range' in that file into a 'CodePointRange' in that file. --- --- Will return 'Nothing' if any of the positions are out of bounds of the document. --- --- Logarithmic in the number of lines in the document, and linear in the length of the lines containing --- the positions. + Will return 'Nothing' if any of the positions are out of bounds of the document. + + Logarithmic in the number of lines in the document, and linear in the length of the lines containing + the positions. +-} rangeToCodePointRange :: VirtualFile -> J.Range -> Maybe CodePointRange 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 - where - (_ ,s1) = Rope.splitAtLine (fromIntegral lf) ropetext - (s2, _) = Rope.splitAtLine (fromIntegral (lt - lf)) s1 - r = Rope.toText s2 --- --------------------------------------------------------------------- +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/DiagnosticsSpec.hs b/test/DiagnosticsSpec.hs --- a/test/DiagnosticsSpec.hs +++ b/test/DiagnosticsSpec.hs @@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} -module DiagnosticsSpec where +module DiagnosticsSpec where -import qualified Data.Map as Map -import qualified Data.HashMap.Strict as HM -import qualified Data.SortedList as SL -import Data.Text (Text) -import Language.LSP.Diagnostics -import qualified Language.LSP.Types as J +import Data.HashMap.Strict qualified as HM +import Data.Map qualified as Map +import Data.SortedList qualified as SL +import Data.Text (Text) +import Language.LSP.Diagnostics +import Language.LSP.Protocol.Types qualified as LSP -import Test.Hspec +import Test.Hspec -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -- --------------------------------------------------------------------- @@ -29,20 +29,21 @@ -- --------------------------------------------------------------------- -mkDiagnostic :: Maybe J.DiagnosticSource -> Text -> J.Diagnostic +mkDiagnostic :: Maybe Text -> Text -> LSP.Diagnostic mkDiagnostic ms str = let - rng = J.Range (J.Position 0 1) (J.Position 3 0) - loc = J.Location (J.Uri "file") rng - in - J.Diagnostic rng Nothing Nothing ms str Nothing (Just (J.List [J.DiagnosticRelatedInformation loc str])) + rng = LSP.Range (LSP.Position 0 1) (LSP.Position 3 0) + loc = LSP.Location (LSP.Uri "file") rng + in + LSP.Diagnostic rng Nothing Nothing Nothing ms str Nothing (Just [LSP.DiagnosticRelatedInformation loc str]) Nothing -mkDiagnostic2 :: Maybe J.DiagnosticSource -> Text -> J.Diagnostic +mkDiagnostic2 :: Maybe Text -> Text -> LSP.Diagnostic mkDiagnostic2 ms str = let - rng = J.Range (J.Position 4 1) (J.Position 5 0) - loc = J.Location (J.Uri "file") rng - in J.Diagnostic rng Nothing Nothing ms str Nothing (Just (J.List [J.DiagnosticRelatedInformation loc str])) + rng = LSP.Range (LSP.Position 4 1) (LSP.Position 5 0) + loc = LSP.Location (LSP.Uri "file") rng + in + LSP.Diagnostic rng Nothing Nothing Nothing ms str Nothing (Just [LSP.DiagnosticRelatedInformation loc str]) Nothing -- --------------------------------------------------------------------- @@ -55,10 +56,10 @@ [ mkDiagnostic (Just "hlint") "a" , mkDiagnostic (Just "hlint") "b" ] - uri = J.toNormalizedUri $ J.Uri "uri" - (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags) ] ) + uri = LSP.toNormalizedUri $ LSP.Uri "uri" + (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) + `shouldBe` HM.fromList + [ (uri, StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags)]) ] -- --------------------------------- @@ -69,13 +70,17 @@ [ mkDiagnostic (Just "hlint") "a" , mkDiagnostic (Just "ghcmod") "b" ] - uri = J.toNormalizedUri $ J.Uri "uri" - (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList - [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) - ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) - ]) + uri = LSP.toNormalizedUri $ LSP.Uri "uri" + (updateDiagnostics HM.empty uri Nothing (partitionBySource diags)) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem Nothing $ + Map.fromList + [ (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) + , (Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) + ] + ) ] -- --------------------------------- @@ -86,16 +91,20 @@ [ mkDiagnostic (Just "hlint") "a" , mkDiagnostic (Just "ghcmod") "b" ] - uri = J.toNormalizedUri $ J.Uri "uri" - (updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)) `shouldBe` - HM.fromList - [ (uri,StoreItem (Just 1) $ Map.fromList - [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) - ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) - ]) + uri = LSP.toNormalizedUri $ LSP.Uri "uri" + (updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem (Just 1) $ + Map.fromList + [ (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a")) + , (Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b")) + ] + ) ] - -- --------------------------------- + -- --------------------------------- describe "updates a store for same document version" $ do it "updates a store without a document version, single source only" $ do @@ -107,11 +116,11 @@ diags2 = [ mkDiagnostic (Just "hlint") "a2" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) - (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] ) + (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) + `shouldBe` HM.fromList + [ (uri, StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags2)]) ] -- --------------------------------- @@ -125,14 +134,18 @@ diags2 = [ mkDiagnostic (Just "hlint") "a2" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) - (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList - [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) - ,(Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b1")) - ] ) + (updateDiagnostics origStore uri Nothing (partitionBySource diags2)) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem Nothing $ + Map.fromList + [ (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) + , (Just "ghcmod", SL.singleton (mkDiagnostic (Just "ghcmod") "b1")) + ] + ) ] -- --------------------------------- @@ -143,18 +156,21 @@ [ mkDiagnostic (Just "hlint") "a1" , mkDiagnostic (Just "ghcmod") "b1" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri Nothing (partitionBySource diags1) - (updateDiagnostics origStore uri Nothing (Map.fromList [(Just "ghcmod",SL.toSortedList [])])) `shouldBe` - HM.fromList - [ (uri,StoreItem Nothing $ Map.fromList - [(Just "ghcmod", SL.toSortedList []) - ,(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a1")) - ] ) + (updateDiagnostics origStore uri Nothing (Map.fromList [(Just "ghcmod", SL.toSortedList [])])) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem Nothing $ + Map.fromList + [ (Just "ghcmod", SL.toSortedList []) + , (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a1")) + ] + ) ] - - -- --------------------------------- + -- --------------------------------- describe "updates a store for a new document version" $ do it "updates a store without a document version, single source only" $ do @@ -166,11 +182,11 @@ diags2 = [ mkDiagnostic (Just "hlint") "a2" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags1) - (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) `shouldBe` - HM.fromList - [ (uri,StoreItem (Just 2) $ Map.fromList [(Just "hlint", SL.toSortedList diags2) ] ) + (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) + `shouldBe` HM.fromList + [ (uri, StoreItem (Just 2) $ Map.fromList [(Just "hlint", SL.toSortedList diags2)]) ] -- --------------------------------- @@ -184,86 +200,99 @@ diags2 = [ mkDiagnostic (Just "hlint") "a2" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let origStore = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags1) - (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) `shouldBe` - HM.fromList - [ (uri,StoreItem (Just 2) $ Map.fromList - [(Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) - ] ) + (updateDiagnostics origStore uri (Just 2) (partitionBySource diags2)) + `shouldBe` HM.fromList + [ + ( uri + , StoreItem (Just 2) $ + Map.fromList + [ (Just "hlint", SL.singleton (mkDiagnostic (Just "hlint") "a2")) + ] + ) ] - -- --------------------------------- + -- --------------------------------- describe "retrieves all the diagnostics for a given uri" $ do - it "gets diagnostics for multiple sources" $ do let diags = [ mkDiagnostic (Just "hlint") "a" , mkDiagnostic (Just "ghcmod") "b" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - getDiagnosticParamsFor 10 ds uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) (J.List $ reverse diags)) + getDiagnosticParamsFor 10 ds uri + `shouldBe` Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) (reverse diags)) - -- --------------------------------- + -- --------------------------------- describe "limits the number of diagnostics retrieved, in order" $ do - it "gets diagnostics for multiple sources" $ do let diags = [ mkDiagnostic2 (Just "hlint") "a" , mkDiagnostic2 (Just "ghcmod") "b" - , mkDiagnostic (Just "hlint") "c" - , mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic (Just "ghcmod") "d" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - getDiagnosticParamsFor 2 ds uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) - (J.List [ - mkDiagnostic (Just "ghcmod") "d" - , mkDiagnostic (Just "hlint") "c" - ])) + getDiagnosticParamsFor 2 ds uri + `shouldBe` Just + ( LSP.PublishDiagnosticsParams + (LSP.fromNormalizedUri uri) + (Just 1) + [ mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + ] + ) - getDiagnosticParamsFor 1 ds uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) - (J.List [ - mkDiagnostic (Just "ghcmod") "d" - ])) + getDiagnosticParamsFor 1 ds uri + `shouldBe` Just + ( LSP.PublishDiagnosticsParams + (LSP.fromNormalizedUri uri) + (Just 1) + [ mkDiagnostic (Just "ghcmod") "d" + ] + ) - -- --------------------------------- + -- --------------------------------- describe "flushes the diagnostics for a given source" $ do - it "gets diagnostics for multiple sources" $ do let diags = [ mkDiagnostic2 (Just "hlint") "a" , mkDiagnostic2 (Just "ghcmod") "b" - , mkDiagnostic (Just "hlint") "c" - , mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic (Just "ghcmod") "d" ] - uri = J.toNormalizedUri $ J.Uri "uri" + uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags) - getDiagnosticParamsFor 100 ds uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) - (J.List [ - mkDiagnostic (Just "ghcmod") "d" - , mkDiagnostic (Just "hlint") "c" - , mkDiagnostic2 (Just "ghcmod") "b" - , mkDiagnostic2 (Just "hlint") "a" - ])) + getDiagnosticParamsFor 100 ds uri + `shouldBe` Just + ( LSP.PublishDiagnosticsParams + (LSP.fromNormalizedUri uri) + (Just 1) + [ mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic (Just "hlint") "c" + , mkDiagnostic2 (Just "ghcmod") "b" + , mkDiagnostic2 (Just "hlint") "a" + ] + ) let ds' = flushBySource ds (Just "hlint") - getDiagnosticParamsFor 100 ds' uri `shouldBe` - Just (J.PublishDiagnosticsParams (J.fromNormalizedUri uri) (Just 1) - (J.List [ - mkDiagnostic (Just "ghcmod") "d" - , mkDiagnostic2 (Just "ghcmod") "b" - ])) + getDiagnosticParamsFor 100 ds' uri + `shouldBe` Just + ( LSP.PublishDiagnosticsParams + (LSP.fromNormalizedUri uri) + (Just 1) + [ mkDiagnostic (Just "ghcmod") "d" + , mkDiagnostic2 (Just "ghcmod") "b" + ] + ) - -- --------------------------------- +-- --------------------------------- diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,7 +1,7 @@ module Main where +import Spec qualified import Test.Hspec.Runner -import qualified Spec main :: IO () main = hspec Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} + {- See https://github.com/hspec/hspec/tree/master/hspec-discover#readme diff --git a/test/VspSpec.hs b/test/VspSpec.hs --- a/test/VspSpec.hs +++ b/test/VspSpec.hs @@ -1,14 +1,16 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedStrings #-} + module VspSpec where -import Data.String -import qualified Data.Text.Utf16.Rope as Rope -import Language.LSP.VFS -import qualified Language.LSP.Types as J -import qualified Data.Text as T +import Data.String +import Data.Text qualified as T +import Data.Text.Utf16.Rope.Mixed qualified as Rope +import Language.LSP.Protocol.Types qualified as J +import Language.LSP.VFS -import Test.Hspec import Data.Functor.Identity +import Test.Hspec -- --------------------------------------------------------------------- @@ -27,62 +29,49 @@ -- --------------------------------------------------------------------- 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 $ J.TextDocumentContentChangePartial{J._range = r, J._rangeLength = Nothing, J._text = t} + vspSpec :: Spec vspSpec = do describe "applys changes in order" $ do it "handles vscode style undos" $ do let orig = "abc" changes = - [ J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 2 0 3) Nothing "" - , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 1 0 2) Nothing "" - , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 0 0 1) Nothing "" + [ mkChangeEvent (J.mkRange 0 2 0 3) "" + , mkChangeEvent (J.mkRange 0 1 0 2) "" + , mkChangeEvent (J.mkRange 0 0 0 1) "" ] applyChanges mempty orig changes `shouldBe` Identity "" it "handles vscode style redos" $ do let orig = "" changes = - [ J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 1 0 1) Nothing "a" - , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 2 0 2) Nothing "b" - , J.TextDocumentContentChangeEvent (Just $ J.mkRange 0 3 0 3) Nothing "c" + [ mkChangeEvent (J.mkRange 0 1 0 1) "a" + , mkChangeEvent (J.mkRange 0 2 0 2) "b" + , mkChangeEvent (J.mkRange 0 3 0 3) "c" ] applyChanges mempty orig changes `shouldBe` Identity "abc" - -- --------------------------------- + -- --------------------------------- describe "deletes characters" $ do it "deletes characters within a line" $ do -- based on vscode log let - orig = unlines - [ "abcdg" - , "module Foo where" - , "-- fooo" - , "foo :: Int" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 1 2 5) (Just 4) "" - Rope.lines <$> new `shouldBe` Identity - [ "abcdg" - , "module Foo where" - , "-oo" - , "foo :: Int" - ] - - it "deletes characters within a line (no len)" $ do - let - orig = unlines - [ "abcdg" - , "module Foo where" - , "-- fooo" - , "foo :: Int" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 1 2 5) Nothing "" - Rope.lines <$> new `shouldBe` Identity + orig = + unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 2 1 2 5) "" + Rope.lines <$> new + `shouldBe` Identity [ "abcdg" , "module Foo where" , "-oo" @@ -94,83 +83,55 @@ it "deletes one line" $ do -- based on vscode log let - orig = unlines - [ "abcdg" - , "module Foo where" - , "-- fooo" - , "foo :: Int" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 0 3 0) (Just 8) "" - Rope.lines <$> new `shouldBe` Identity + orig = + unlines + [ "abcdg" + , "module Foo where" + , "-- fooo" + , "foo :: Int" + ] + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 2 0 3 0) "" + Rope.lines <$> new + `shouldBe` Identity [ "abcdg" , "module Foo where" , "foo :: Int" ] - it "deletes one line(no len)" $ do - -- based on vscode log - let - orig = unlines - [ "abcdg" - , "module Foo where" - , "-- fooo" - , "foo :: Int" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 2 0 3 0) Nothing "" - Rope.lines <$> new `shouldBe` Identity - [ "abcdg" - , "module Foo where" - , "foo :: Int" - ] -- --------------------------------- it "deletes two lines" $ do -- based on vscode log let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 3 0) (Just 19) "" - Rope.lines <$> new `shouldBe` Identity + orig = + unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 0 3 0) "" + Rope.lines <$> new + `shouldBe` Identity [ "module Foo where" , "foo = bb" ] - it "deletes two lines(no len)" $ do - -- based on vscode log - let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 3 0) Nothing "" - Rope.lines <$> new `shouldBe` Identity - [ "module Foo where" - , "foo = bb" - ] - -- --------------------------------- + -- --------------------------------- describe "adds characters" $ do it "adds one line" $ do -- based on vscode log let - orig = unlines - [ "abcdg" - , "module Foo where" - , "foo :: Int" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 16 1 16) (Just 0) "\n-- fooo" - Rope.lines <$> new `shouldBe` Identity + orig = + unlines + [ "abcdg" + , "module Foo where" + , "foo :: Int" + ] + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 16 1 16) "\n-- fooo" + Rope.lines <$> new + `shouldBe` Identity [ "abcdg" , "module Foo where" , "-- fooo" @@ -182,68 +143,42 @@ it "adds two lines" $ do -- based on vscode log let - orig = unlines - [ "module Foo where" - , "foo = bb" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 8 1 8) Nothing "\n-- fooo\nfoo :: Int" - Rope.lines <$> new `shouldBe` Identity + orig = + unlines + [ "module Foo where" + , "foo = bb" + ] + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 8 1 8) "\n-- fooo\nfoo :: Int" + Rope.lines <$> new + `shouldBe` Identity [ "module Foo where" , "foo = bb" , "-- fooo" , "foo :: Int" ] - -- --------------------------------- + -- --------------------------------- describe "changes characters" $ do it "removes end of a line" $ do -- based on vscode log let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - , "" - , "bb = 5" - , "" - , "baz = do" - , " putStrLn \"hello world\"" - ] - -- new = changeChars (fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 7 0 7 8) (Just 8) "baz =" - Rope.lines <$> new `shouldBe` Identity - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - , "" - , "bb = 5" - , "" - , "baz =" - , " putStrLn \"hello world\"" - ] - it "removes end of a line(no len)" $ do - -- based on vscode log - let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - , "" - , "bb = 5" - , "" - , "baz = do" - , " putStrLn \"hello world\"" - ] + orig = + unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] -- new = changeChars (fromString orig) (J.Position 7 0) (J.Position 7 8) "baz =" - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 7 0 7 8) Nothing "baz =" - Rope.lines <$> new `shouldBe` Identity + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 7 0 7 8) "baz =" + Rope.lines <$> new + `shouldBe` Identity [ "module Foo where" , "-- fooo" , "foo :: Int" @@ -256,56 +191,59 @@ ] it "indexes using utf-16 code units" $ do let - orig = unlines - [ "a𐐀b" - , "a𐐀b" - ] - new = applyChange mempty (fromString orig) - $ J.TextDocumentContentChangeEvent (Just $ J.mkRange 1 0 1 3) (Just 3) "𐐀𐐀" - Rope.lines <$> new `shouldBe` Identity + orig = + unlines + [ "a𐐀b" + , "a𐐀b" + ] + new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 0 1 3) "𐐀𐐀" + Rope.lines <$> new + `shouldBe` Identity [ "a𐐀b" , "𐐀𐐀b" ] - -- --------------------------------- + -- --------------------------------- describe "LSP utilities" $ do it "splits at a line" $ do let - orig = unlines - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - , "" - , "bb = 5" - , "" - , "baz = do" - , " putStrLn \"hello world\"" - ] - (left,right) = Rope.splitAtLine 4 (fromString orig) + orig = + unlines + [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + , "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] + (left, right) = Rope.splitAtLine 4 (fromString orig) - Rope.lines left `shouldBe` - [ "module Foo where" - , "-- fooo" - , "foo :: Int" - , "foo = bb" - ] - Rope.lines right `shouldBe` - [ "" - , "bb = 5" - , "" - , "baz = do" - , " putStrLn \"hello world\"" - ] + Rope.lines left + `shouldBe` [ "module Foo where" + , "-- fooo" + , "foo :: Int" + , "foo = bb" + ] + Rope.lines right + `shouldBe` [ "" + , "bb = 5" + , "" + , "baz = do" + , " putStrLn \"hello world\"" + ] it "converts code units to code points" $ do let - orig = unlines - [ "a𐐀b" - , "a𐐀b" - ] - vfile = VirtualFile 0 0 (fromString orig) + orig = + unlines + [ "a𐐀b" + , "a𐐀b" + ] + 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) @@ -322,11 +260,12 @@ it "converts code points to code units" $ do let - orig = unlines - [ "a𐐀b" - , "a𐐀b" - ] - vfile = VirtualFile 0 0 (fromString orig) + orig = + unlines + [ "a𐐀b" + , "a𐐀b" + ] + 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) @@ -338,26 +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))