lsp 1.6.0.0 → 2.8.0.0
raw patch · 16 files changed
Files
- ChangeLog.md +82/−2
- example/Reactor.hs +220/−213
- example/Simple.hs +44/−34
- lsp.cabal +125/−104
- src/Language/LSP/Diagnostics.hs +58/−46
- src/Language/LSP/Logging.hs +23/−18
- src/Language/LSP/Server.hs +54/−47
- src/Language/LSP/Server/Control.hs +364/−162
- src/Language/LSP/Server/Core.hs +908/−740
- src/Language/LSP/Server/Processing.hs +531/−322
- src/Language/LSP/Server/Progress.hs +237/−0
- src/Language/LSP/VFS.hs +325/−342
- test/DiagnosticsSpec.hs +137/−108
- test/Main.hs +1/−1
- test/Spec.hs +1/−0
- test/VspSpec.hs +130/−214
ChangeLog.md view
@@ -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 }
example/Reactor.hs view
@@ -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)+ ] -- ---------------------------------------------------------------------
example/Simple.hs view
@@ -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+ }
lsp.cabal view
@@ -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
src/Language/LSP/Diagnostics.hs view
@@ -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) -- ---------------------------------------------------------------------
src/Language/LSP/Logging.hs view
@@ -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
src/Language/LSP/Server.hs view
@@ -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
src/Language/LSP/Server/Control.hs view
@@ -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"
src/Language/LSP/Server/Core.hs view
@@ -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`.+-}
src/Language/LSP/Server/Processing.hs view
@@ -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
+ src/Language/LSP/Server/Progress.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE LambdaCase #-}++module Language.LSP.Server.Progress (+ withProgress,+ withIndefiniteProgress,+ ProgressAmount (..),+ ProgressCancellable (..),+ ProgressCancelledException,+) where++import Control.Concurrent.Async+import Control.Concurrent.Extra as C+import Control.Concurrent.STM+import Control.Exception qualified as E+import Control.Lens hiding (Empty)+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Data.Aeson qualified as J+import Data.Foldable+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Text (Text)+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+import Language.LSP.Protocol.Types qualified as L+import Language.LSP.Server.Core+import UnliftIO qualified as U+import UnliftIO.Exception qualified as UE++{- | A package indicating the percentage of progress complete and a+ an optional message to go with it during a 'withProgress'++ @since 0.10.0.0+-}+data ProgressAmount = ProgressAmount (Maybe UInt) (Maybe Text)++{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session++ @since 0.11.0.0+-}+data ProgressCancelledException = ProgressCancelledException+ deriving (Show)++instance E.Exception ProgressCancelledException++{- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress'+ session++ @since 0.11.0.0+-}+data ProgressCancellable = Cancellable | NotCancellable++-- Get a new id for the progress session and make a new one+getNewProgressId :: MonadLsp config m => m ProgressToken+getNewProgressId = do+ stateState (progressNextId . resProgressData) $ \cur ->+ let !next = cur + 1+ in (L.ProgressToken $ L.InL cur, next)+{-# INLINE getNewProgressId #-}++withProgressBase ::+ forall c m a.+ MonadLsp c m =>+ Bool ->+ Text ->+ Maybe ProgressToken ->+ ProgressCancellable ->+ ((ProgressAmount -> m ()) -> m a) ->+ m a+withProgressBase indefinite title clientToken cancellable f = do+ let initialProgress = ProgressAmount (if indefinite then Nothing else Just 0) Nothing+ LanguageContextEnv{resProgressStartDelay = startDelay, resProgressUpdateDelay = updateDelay} <- getLspEnv++ tokenVar <- liftIO newEmptyTMVarIO+ reportVar <- liftIO $ newTMVarIO initialProgress+ endBarrier <- liftIO newEmptyMVar++ let+ updater :: ProgressAmount -> m ()+ updater pa = liftIO $ atomically $ do+ -- I don't know of a way to do this with a normal MVar!+ -- That is: put something into it regardless of whether it is full or empty+ _ <- tryTakeTMVar reportVar+ putTMVar reportVar pa++ progressEnded :: IO ()+ progressEnded = readMVar endBarrier++ endProgress :: IO ()+ endProgress = void $ tryPutMVar endBarrier ()++ -- Once we have a 'ProgressToken', store it in the variable and also register the cancellation+ -- handler.+ registerToken :: ProgressToken -> m ()+ registerToken t = do+ handlers <- getProgressCancellationHandlers+ liftIO $ atomically $ do+ putTMVar tokenVar t+ modifyTVar handlers (Map.insert t endProgress)++ -- Deregister our 'ProgressToken', specifically its cancellation handler. It is important+ -- to do this reliably or else we will leak handlers.+ unregisterToken :: m ()+ unregisterToken = do+ handlers <- getProgressCancellationHandlers+ liftIO $ atomically $ do+ mt <- tryReadTMVar tokenVar+ for_ mt $ \t -> modifyTVar handlers (Map.delete t)++ -- Find and register our 'ProgressToken', asking the client for it if necessary.+ -- Note that this computation may terminate before we get the token, we need to wait+ -- for the token var to be filled if we want to use it.+ createToken :: m ()+ createToken = do+ -- See Note [Delayed progress reporting]+ -- This delays the creation of the token as well as the 'begin' message. Creating+ -- the token shouldn't result in any visible action on the client side since+ -- the title/initial percentage aren't given until the 'begin' mesage. However,+ -- it's neater not to create tokens that we won't use, and clients may find it+ -- easier to clean them up if they receive begin/end reports for them.+ liftIO $ threadDelay startDelay+ case clientToken of+ -- See Note [Client- versus server-initiated progress]+ -- Client-initiated progress+ Just t -> registerToken t+ -- Try server-initiated progress+ Nothing -> do+ t <- getNewProgressId+ clientCaps <- getClientCapabilities++ -- If we don't have a progress token from the client and+ -- the client doesn't support server-initiated progress then+ -- there's nothing to do: we can't report progress.+ when (clientSupportsServerInitiatedProgress clientCaps)+ $ void+ $+ -- Server-initiated progress+ -- See Note [Client- versus server-initiated progress]+ sendRequest+ SMethod_WindowWorkDoneProgressCreate+ (WorkDoneProgressCreateParams t)+ $ \case+ -- Successfully registered the token, we can now use it.+ -- So we go ahead and start. We do this as soon as we get the+ -- token back so the client gets feedback ASAP+ Right _ -> registerToken t+ -- The client sent us an error, we can't use the token.+ Left _err -> pure ()++ -- Actually send the progress reports.+ sendReports :: m ()+ sendReports = do+ t <- liftIO $ atomically $ readTMVar tokenVar+ begin t+ -- Once we are sending updates, if we get interrupted we should send+ -- the end notification+ update t `UE.finally` end t+ where+ cancellable' = case cancellable of+ Cancellable -> Just True+ NotCancellable -> Just False+ begin t = do+ (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar+ sendProgressReport t $ WorkDoneProgressBegin L.AString title cancellable' msg pct+ update t =+ forever $ do+ -- See Note [Delayed progress reporting]+ liftIO $ threadDelay updateDelay+ (ProgressAmount pct msg) <- liftIO $ atomically $ takeTMVar reportVar+ sendProgressReport t $ WorkDoneProgressReport L.AString Nothing msg pct+ end t = sendProgressReport t (WorkDoneProgressEnd L.AString Nothing)++ -- Create the token and then start sending reports; all of which races with the check for the+ -- progress having ended. In all cases, make sure to unregister the token at the end.+ progressThreads :: m ()+ progressThreads =+ ((createToken >> sendReports) `UE.finally` unregisterToken) `U.race_` liftIO progressEnded++ withRunInIO $ \runInBase -> do+ withAsync (runInBase $ f updater) $ \mainAct ->+ -- If the progress gets cancelled then we need to get cancelled too+ withAsync (runInBase progressThreads) $ \pthreads -> do+ r <- waitEither mainAct pthreads+ -- TODO: is this weird? I can't see how else to gracefully use the ending barrier+ -- as a guard to cancel the other async+ case r of+ Left a -> pure a+ Right _ -> cancelWith mainAct ProgressCancelledException >> wait mainAct+ where+ sendProgressReport :: (J.ToJSON r) => ProgressToken -> r -> m ()+ sendProgressReport token report = sendNotification SMethod_Progress $ ProgressParams token $ J.toJSON report++ getProgressCancellationHandlers :: m (TVar (Map.Map ProgressToken (IO ())))+ getProgressCancellationHandlers = getStateVar (progressCancel . resProgressData)++clientSupportsServerInitiatedProgress :: L.ClientCapabilities -> Bool+clientSupportsServerInitiatedProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just+{-# INLINE clientSupportsServerInitiatedProgress #-}++{- |+Wrapper for reporting progress to the client during a long running task.+-}+withProgress ::+ MonadLsp c m =>+ -- | The title of the progress operation+ Text ->+ -- | The progress token provided by the client in the method params, if any+ Maybe ProgressToken ->+ -- | Whether or not this operation is cancellable. If true, the user will be+ -- shown a button to allow cancellation. Note that requests can still be cancelled+ -- even if this is not set.+ ProgressCancellable ->+ -- | An update function to pass progress updates to+ ((ProgressAmount -> m ()) -> m a) ->+ m a+withProgress title clientToken cancellable f = withProgressBase False title clientToken cancellable f++{- |+Same as 'withProgress', but for processes that do not report the precentage complete.+-}+withIndefiniteProgress ::+ MonadLsp c m =>+ -- | The title of the progress operation+ Text ->+ -- | The progress token provided by the client in the method params, if any+ Maybe ProgressToken ->+ -- | Whether or not this operation is cancellable. If true, the user will be+ -- shown a button to allow cancellation. Note that requests can still be cancelled+ -- even if this is not set.+ ProgressCancellable ->+ -- | An update function to pass progress updates to+ ((Text -> m ()) -> m a) ->+ m a+withIndefiniteProgress title clientToken cancellable f =+ withProgressBase True title clientToken cancellable (\update -> f (\msg -> update (ProgressAmount Nothing (Just msg))))
src/Language/LSP/VFS.hs view
@@ -1,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
test/DiagnosticsSpec.hs view
@@ -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"+ ]+ ) - -- ---------------------------------+-- ---------------------------------
test/Main.hs view
@@ -1,7 +1,7 @@ module Main where +import Spec qualified import Test.Hspec.Runner-import qualified Spec main :: IO () main = hspec Spec.spec
test/Spec.hs view
@@ -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
test/VspSpec.hs view
@@ -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))