lsp 2.2.0.0 → 2.3.0.0
raw patch · 15 files changed
+1836/−1662 lines, 15 filesdep −temporarydep ~lsp-typesdep ~sorted-list
Dependencies removed: temporary
Dependency ranges changed: lsp-types, sorted-list
Files
- ChangeLog.md +6/−0
- example/Reactor.hs +217/−213
- example/Simple.hs +37/−31
- lsp.cabal +6/−3
- src/Language/LSP/Diagnostics.hs +39/−36
- src/Language/LSP/Logging.hs +19/−15
- src/Language/LSP/Server.hs +47/−50
- src/Language/LSP/Server/Control.hs +156/−145
- src/Language/LSP/Server/Core.hs +429/−434
- src/Language/LSP/Server/Processing.hs +361/−286
- src/Language/LSP/VFS.hs +283/−261
- test/DiagnosticsSpec.hs +116/−87
- test/Main.hs +1/−1
- test/Spec.hs +1/−0
- test/VspSpec.hs +118/−100
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for lsp +## 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
example/Reactor.hs view
@@ -1,13 +1,12 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeInType #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-}-+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeInType #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-}@@ -28,35 +27,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.Protocol.Types as LSP-import qualified Language.LSP.Protocol.Lens as LSP-import qualified Language.LSP.Protocol.Message as LSP-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 Data.Text.Prettyprint.Doc+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 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) #-}+ -- --------------------------------------------------------------------- -- @@ -68,13 +67,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:@@ -88,54 +86,57 @@ dualLogger :: LogAction (LspM Config) (WithSeverity T.Text) dualLogger = clientLogger <> L.hoistLogAction liftIO stderrLogger - 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- }+ 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 :: 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- }+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- { optTextDocumentSync = Just syncOptions- , optExecuteCommandCommands = Just ["lsp-hello-command"]- }+lspOptions =+ defaultOptions+ { optTextDocumentSync = Just syncOptions+ , optExecuteCommandCommands = Just ["lsp-hello-command"]+ } -- --------------------------------------------------------------------- @@ -146,29 +147,32 @@ newtype ReactorInput = ReactorAction (IO ()) --- | Analyze the file and send any diagnostics to the client in a--- "textDocument/publishDiagnostics" notification+{- | 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 = [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- ]+ 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@@ -176,143 +180,143 @@ 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 :: 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)+ 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 :: 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)+ 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 LSP.SMethod_Initialized $ \_msg -> do- logger <& "Processing the Initialized notification" `WithSeverity` Info- - -- 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"])-- 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")-- -- 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")- - let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False)- - void $ registerCapability LSP.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do- logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info- let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing- rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing]- responder (Right $ LSP.InL rsp)-- , 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)+handle logger =+ mconcat+ [ notificationHandler LSP.SMethod_Initialized $ \_msg -> do+ logger <& "Processing the Initialized notification" `WithSeverity` Info - , 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)+ -- 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 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)+ 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 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- in [LSP.Command title cmd cmdparams]- makeCommand _ = []- rsp = map LSP.InL $ concatMap makeCommand diags- responder (Right $ LSP.InL 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 LSP.SMethod_WorkspaceExecuteCommand $ \req responder -> do- logger <& "Processing a workspace/executeCommand request" `WithSeverity` Info- let params = req ^. LSP.params- margs = params ^. LSP.arguments+ let regOpts = LSP.CodeLensRegistrationOptions (LSP.InR LSP.Null) Nothing (Just False) - logger <& ("The arguments are: " <> T.pack (show margs)) `WithSeverity` Debug- responder (Right $ LSP.InL (J.Object mempty)) -- respond to the request+ void $ registerCapability LSP.SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do+ logger <& "Processing a textDocument/codeLens request" `WithSeverity` Info+ let cmd = LSP.Command "Say hello" "lsp-hello-command" Nothing+ rsp = [LSP.CodeLens (LSP.mkRange 0 0 0 100) (Just cmd) Nothing]+ responder (Right $ LSP.InL rsp)+ , 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+ 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 :: LSP.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" 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,22 +1,26 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} -import Language.LSP.Server-import Language.LSP.Protocol.Types -import Language.LSP.Protocol.Message 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 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+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 SMethod_TextDocumentCodeLens regOpts $ \_req responder -> do let cmd = Command "Say hello" "lsp-hello-command" Nothing rsp = [CodeLens (mkRange 0 0 0 100) (Just cmd) Nothing]@@ -26,24 +30,26 @@ sendNotification SMethod_WindowShowMessage (ShowMessageParams MessageType_Info "Not turning on code lenses") Left err -> 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)- ]+ 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- { 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- }+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,6 +1,6 @@ cabal-version: 2.2 name: lsp-version: 2.2.0.0+version: 2.3.0.0 synopsis: Haskell library for the Microsoft Language Server Protocol description: An implementation of the types, and basic message server to@@ -29,6 +29,7 @@ library hs-source-dirs: src default-language: Haskell2010+ default-extensions: ImportQualifiedPost ghc-options: -Wall -fprint-explicit-kinds reexported-modules:@@ -64,14 +65,13 @@ , hashable , lens-aeson , lens >=4.15.2- , lsp-types ^>=2.0.1+ , lsp-types ^>=2.1 , mtl <2.4 , prettyprinter , random , row-types , sorted-list ^>=0.2.1 , stm ^>=2.5- , temporary , text , text-rope , transformers >=0.5.6 && <0.7@@ -83,6 +83,7 @@ main-is: Reactor.hs hs-source-dirs: example default-language: Haskell2010+ default-extensions: ImportQualifiedPost ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: , aeson@@ -102,6 +103,7 @@ main-is: Simple.hs hs-source-dirs: example default-language: Haskell2010+ default-extensions: ImportQualifiedPost ghc-options: -Wall -Wno-unticked-promoted-constructors build-depends: , base@@ -139,3 +141,4 @@ build-tool-depends: hspec-discover:hspec-discover ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall default-language: Haskell2010+ default-extensions: ImportQualifiedPost
src/Language/LSP/Diagnostics.hs view
@@ -7,28 +7,28 @@ 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,+ 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 Data.HashMap.Strict qualified as HM+import Data.Map.Strict qualified as Map+import Data.SortedList qualified as SL import Data.Text (Text)-import qualified Language.LSP.Protocol.Types as J+import Language.LSP.Protocol.Types qualified as J -- --------------------------------------------------------------------- {-# ANN module ("hlint: ignore Eta reduce" :: String) #-} {-# ANN module ("hlint: ignore Redundant do" :: String) #-}+ -- --------------------------------------------------------------------- {-@@ -45,7 +45,7 @@ data StoreItem = StoreItem (Maybe J.Int32) DiagnosticsBySource- deriving (Show,Eq)+ deriving (Show, Eq) type DiagnosticsBySource = Map.Map (Maybe Text) (SL.SortedList J.Diagnostic) @@ -57,34 +57,37 @@ -- --------------------------------------------------------------------- flushBySource :: DiagnosticStore -> Maybe Text -> DiagnosticStore-flushBySource store Nothing = store+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) -- --------------------------------------------------------------------- -updateDiagnostics :: DiagnosticStore- -> J.NormalizedUri -> Maybe J.Int32 -> 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 -- ---------------------------------------------------------------------
src/Language/LSP/Logging.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-}+ module Language.LSP.Logging (logToShowMessage, logToLogMessage, defaultClientLogger) where import Colog.Core-import Language.LSP.Server.Core-import Language.LSP.Protocol.Types-import Language.LSP.Protocol.Message 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@@ -17,23 +18,26 @@ -- | Logs messages to the client via @window/logMessage@. logToLogMessage :: (MonadLsp c m) => LogAction m (WithSeverity Text) logToLogMessage = LogAction $ \(WithSeverity msg sev) -> do- sendToClient $ fromServerNot $- TNotificationMessage "2.0" SMethod_WindowLogMessage (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 $- TNotificationMessage "2.0" SMethod_WindowShowMessage (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,68 +1,65 @@ {-# LANGUAGE TypeOperators #-}-module Language.LSP.Server- ( module Language.LSP.Server.Control- , VFSData(..)- , ServerDefinition(..) - -- * 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 (<~>)(..)-- , getClientCapabilities- , getConfig- , setConfig- , getRootPath- , getWorkspaceFolders-- , sendRequest- , sendNotification+ LspT (..),+ LspM,+ MonadLsp (..),+ runLspT,+ LanguageContextEnv (..),+ type (<~>) (..),+ getClientCapabilities,+ getConfig,+ setConfig,+ getRootPath,+ getWorkspaceFolders,+ sendRequest,+ sendNotification, -- * Config- , requestConfigUpdate- , tryChangeConfig+ requestConfigUpdate,+ tryChangeConfig, -- * VFS- , getVirtualFile- , getVirtualFiles- , persistVirtualFile- , getVersionedTextDoc- , reverseFileMap- , snapshotVirtualFiles+ getVirtualFile,+ getVirtualFiles,+ persistVirtualFile,+ getVersionedTextDoc,+ reverseFileMap,+ snapshotVirtualFiles, -- * Diagnostics- , publishDiagnostics- , flushDiagnosticsBySource+ publishDiagnostics,+ flushDiagnosticsBySource, -- * 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
src/Language/LSP/Server/Control.hs view
@@ -1,48 +1,47 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE LambdaCase #-}-+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-} -module Language.LSP.Server.Control- (+module Language.LSP.Server.Control ( -- * Running- runServer- , runServerWith- , runServerWithHandles- , LspServerLog (..)- ) where+ runServer,+ runServerWith,+ runServerWithHandles,+ LspServerLog (..),+) where -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+import Colog.Core (LogAction (..), Severity (..), WithSeverity (..), (<&))+import Colog.Core qualified as L+import Control.Applicative ((<|>))+import Control.Concurrent+import Control.Concurrent.STM.TChan+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 Data.Text.Prettyprint.Doc-import Data.List-import Language.LSP.Server.Core-import qualified Language.LSP.Server.Processing as Processing-import Language.LSP.Protocol.Message-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 Data.Text.Prettyprint.Doc 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 System.IO -data LspServerLog =- LspProcessingLog Processing.LspProcessingLog+data LspServerLog+ = LspProcessingLog Processing.LspProcessingLog | DecodeInitializeError String | HeaderParseFail [String] String | EOF@@ -54,13 +53,13 @@ instance Pretty LspServerLog where 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"@@ -70,46 +69,47 @@ -- --------------------------------------------------------------------- --- | 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+ 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 --- | Starts a language server over the specified handles.--- This function will return once the @exit@ notification is received.+{- | 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@@ -120,21 +120,21 @@ runServerWith ioLogger logger clientIn clientOut serverDefinition --- | Starts listening and sending requests and responses--- using the specified I/O.+{- | 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+ -- | 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.ByteString ->+ -- | Function to provide output to.+ (BSL.ByteString -> IO ()) ->+ ServerDefinition config ->+ IO Int -- exit code runServerWith ioLogger logger clientIn clientOut serverDefinition = do- ioLogger <& Starting `WithSeverity` Info cout <- atomically newTChan :: IO (TChan J.Value)@@ -142,27 +142,26 @@ let sendMsg msg = atomically $ writeTChan cout $ J.toJSON msg - initVFS $ \vfs -> do- ioLoop ioLogger logger clientIn serverDefinition vfs sendMsg+ ioLoop ioLogger logger clientIn serverDefinition emptyVFS sendMsg return 1 -- --------------------------------------------------------------------- ioLoop ::- forall config- . LogAction IO (WithSeverity LspServerLog)- -> LogAction (LspM config) (WithSeverity LspServerLog)- -> IO BS.ByteString- -> ServerDefinition config- -> VFS- -> (FromServerMessage -> IO ())- -> IO ()+ 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 minitialize <- parseOne ioLogger clientIn (parse parser "") case minitialize of Nothing -> pure ()- Just (msg,remainder) -> do+ Just (msg, remainder) -> do case J.eitherDecode $ BSL.fromStrict msg of Left err -> ioLogger <& DecodeInitializeError err `WithSeverity` Error Right initialize -> do@@ -170,51 +169,63 @@ case mInitResp of Nothing -> pure () Just env -> runLspT env $ loop (parse parser remainder)- where+ where+ pioLogger = L.cmap (fmap LspProcessingLog) ioLogger+ pLogger = L.cmap (fmap LspProcessingLog) logger - pioLogger = L.cmap (fmap LspProcessingLog) ioLogger- pLogger = L.cmap (fmap LspProcessingLog) logger+ loop :: Result BS.ByteString -> LspM config ()+ loop = go+ where+ go r = do+ res <- parseOne logger clientIn r+ case res of+ Nothing -> pure ()+ Just (msg, remainder) -> do+ Processing.processMessage pLogger $ BSL.fromStrict msg+ go (parse parser remainder) - loop :: Result BS.ByteString -> LspM config ()- loop = go- where- go r = do- res <- parseOne logger clientIn r- case res of- Nothing -> pure ()- Just (msg,remainder) -> do- Processing.processMessage pLogger $ BSL.fromStrict msg- go (parse parser remainder)+ parser = do+ try contentType <|> (return ())+ len <- contentLength+ try contentType <|> (return ())+ _ <- string _ONE_CRLF+ Attoparsec.take len - parser = do- _ <- string "Content-Length: "- len <- decimal- _ <- string _TWO_CRLF- Attoparsec.take len+ contentLength = do+ _ <- string "Content-Length: "+ len <- decimal+ _ <- string _ONE_CRLF+ return len + contentType = do+ _ <- string "Content-Type: "+ skipWhile (/= '\r')+ _ <- string _ONE_CRLF+ return ()+ 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.ByteString ->+ Result BS.ByteString ->+ 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- -- 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)+ 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+ -- 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) -- --------------------------------------------------------------------- @@ -228,20 +239,20 @@ -- 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 =+ BSL.concat+ [ TL.encodeUtf8 $ TL.pack $ "Content-Length: " ++ show (BSL.length str)+ , BSL.fromStrict _TWO_CRLF+ , str+ ] clientOut out- -- 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 --- |------+-- TODO: figure out how to re-enable+-- This can lead to infinite recursion in logging, see https://github.com/haskell/lsp/issues/447+-- logger <& SendMsg (TL.decodeUtf8 str) `WithSeverity` Debug++_ONE_CRLF :: BS.ByteString+_ONE_CRLF = "\r\n" _TWO_CRLF :: BS.ByteString _TWO_CRLF = "\r\n\r\n"--
src/Language/LSP/Server/Core.hs view
@@ -1,93 +1,100 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-} {-# 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.Async-import Control.Concurrent.STM-import qualified Control.Exception as E-import Control.Lens (_Just, at, (^.), (^?))-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 qualified Data.Aeson as J-import Data.Default-import Data.Functor.Product-import qualified Data.HashMap.Strict as HM-import Data.IxMap-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 Data.Row-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.UUID as UUID-import Language.LSP.Diagnostics-import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Protocol.Message-import qualified Language.LSP.Protocol.Message as L-import Language.LSP.Protocol.Types-import qualified Language.LSP.Protocol.Types as L-import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap)-import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap-import Language.LSP.Protocol.Utils.Misc (prettyJSON)-import Language.LSP.VFS-import Prettyprinter-import System.Random hiding (next)+import Colog.Core (+ LogAction (..),+ Severity (..),+ WithSeverity (..),+ (<&),+ )+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception qualified as E+import Control.Lens (at, (^.), (^?), _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.Row+import Data.Text (Text)+import Data.Text qualified as T+import Data.UUID qualified as UUID+import Language.LSP.Diagnostics+import Language.LSP.Protocol.Capabilities+import Language.LSP.Protocol.Lens qualified as L+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+import Prettyprinter+import System.Random hiding (next) -- ----------------------------------------------------------------------{-# 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) #-}+ -- --------------------------------------------------------------------- -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+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 ResponseError | WrongConfigSections [J.Value]- deriving Show+ deriving (Show) 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:"+ vsep+ [ "LSP: configuration parse error:" , pretty err , "when parsing" , prettyJSON settings@@ -95,7 +102,7 @@ pretty (BadConfigurationResponse err) = "LSP: error when requesting configuration: " <+> pretty err pretty (WrongConfigSections sections) = "LSP: expected only one configuration section, got: " <+> (prettyJSON $ J.toJSON sections) -newtype LspT config m a = LspT { unLspT :: ReaderT (LanguageContextEnv config) m a }+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) @@ -104,7 +111,6 @@ runLspT :: LanguageContextEnv config -> LspT config m a -> m a runLspT env = flip runReaderT env . unLspT- {-# INLINE runLspT #-} type LspM config = LspT config IO@@ -125,38 +131,38 @@ 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)+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)+ , 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+{- | 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@@ -171,43 +177,43 @@ -- | 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+{- | 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 ResponseError (MessageResult m) -> f ()) -> f ()+ Handler f (m :: Method _from Request) = TRequestMessage m -> (Either ResponseError (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+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 ::+ (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+ 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)+data LanguageContextState config = LanguageContextState+ { resVFS :: !(TVar VFSData)+ , resDiagnostics :: !(TVar DiagnosticStore)+ , resConfig :: !(TVar config) , resWorkspaceFolders :: !(TVar [WorkspaceFolder])- , resProgressData :: !ProgressData+ , resProgressData :: !ProgressData , resPendingResponses :: !(TVar ResponseMap) , resRegistrationsNot :: !(TVar (RegistrationMap Notification)) , resRegistrationsReq :: !(TVar (RegistrationMap Request))- , resLspId :: !(TVar Int32)+ , resLspId :: !(TVar Int32) } type ResponseMap = IxMap LspId (Product SMethod ServerResponseCallback)@@ -216,16 +222,17 @@ data RegistrationToken (m :: Method ClientToServer t) = RegistrationToken (SMethod m) (RegistrationId m) newtype RegistrationId (m :: Method ClientToServer t) = RegistrationId Text- deriving Eq+ deriving (Eq) -data ProgressData = ProgressData { progressNextId :: !(TVar Int32)- , progressCancel :: !(TVar (Map.Map ProgressToken (IO ()))) }+data ProgressData = ProgressData+ { progressNextId :: !(TVar Int32)+ , progressCancel :: !(TVar (Map.Map ProgressToken (IO ())))+ } -data VFSData =- VFSData- { vfsData :: !VFS- , reverseMap :: !(Map.Map FilePath FilePath)- }+data VFSData = VFSData+ { vfsData :: !VFS+ , reverseMap :: !(Map.Map FilePath FilePath)+ } {-# INLINE modifyState #-} modifyState :: MonadLsp config m => (LanguageContextState config -> TVar a) -> (a -> a) -> m ()@@ -234,7 +241,7 @@ liftIO $ atomically $ modifyTVar' tvarDat f {-# INLINE stateState #-}-stateState :: MonadLsp config m => (LanguageContextState config -> TVar s) -> (s -> (a,s)) -> m a+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@@ -247,133 +254,149 @@ -- --------------------------------------------------------------------- --- | 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- { optTextDocumentSync :: Maybe L.TextDocumentSyncOptions- -- | The characters that trigger completion automatically.- , optCompletionTriggerCharacters :: 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`.- , optCompletionAllCommitCharacters :: Maybe [Char]- -- | The characters that trigger signature help automatically.- , optSignatureHelpTriggerCharacters :: 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.- , optSignatureHelpRetriggerCharacters :: 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.- , optCodeActionKinds :: 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.- , optDocumentOnTypeFormattingTriggerCharacters :: Maybe (NonEmpty Char)- -- | The commands to be executed on the server.- -- If you set `executeCommandHandler`, you **must** set this.- , optExecuteCommandCommands :: Maybe [Text]- -- | Information about the server that can be advertised to the client.- , optServerInfo :: Maybe (Rec ("name" .== Text .+ "version" .== Maybe Text))- }+{- | 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+ { 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 (Rec ("name" .== Text .+ "version" .== Maybe Text))+ -- ^ Information about the server that can be advertised to the client.+ } instance Default Options where- def = Options Nothing Nothing Nothing Nothing Nothing- Nothing Nothing Nothing Nothing+ 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+{- | 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+{- | Thrown if the user cancels a 'Cancellable' 'withProgress'/'withIndefiniteProgress'/ session++ @since 0.11.0.0+-} data ProgressCancelledException = ProgressCancelledException- deriving Show+ 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+{- | Whether or not the user should be able to cancel a 'withProgress'/'withIndefiniteProgress'+ session++ @since 0.11.0.0+-} data ProgressCancellable = Cancellable | NotCancellable -- See Note [LSP configuration] for discussion of the configuration-related fields--- | Contains all the callbacks to use for initialized the language server.--- it is parameterized over a config type variable representing the type for the--- specific configuration data the language server needs to use.++{- | 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 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 :: 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.- }+ { 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 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 :: 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.+{- | 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 ResponseError (MessageResult m) -> IO ()) --- | Return value signals if response handler was inserted successfully--- Might fail if the id was already in the map+{- | 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 ->@@ -381,22 +404,25 @@ Just !m -> (True, m) Nothing -> (False, pending) -sendNotification- :: forall (m :: Method ServerToClient Notification) f config. MonadLsp config f- => SServerMethod m- -> MessageParams m- -> f ()+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+ 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 ResponseError (MessageResult m) -> f ())- -> f (LspId m)+sendRequest ::+ forall (m :: Method ServerToClient Request) f config.+ MonadLsp config f =>+ SServerMethod m ->+ MessageParams m ->+ (Either ResponseError (MessageResult m) -> f ()) ->+ f (LspId m) sendRequest m params resHandler = do reqId <- IdInt <$> freshLspId rio <- askRunInIO@@ -405,7 +431,7 @@ let msg = TRequestMessage "2.0" reqId m params ~() <- case splitServerMethod m of- IsServerReq -> sendToClient $ fromServerReq msg+ IsServerReq -> sendToClient $ fromServerReq msg IsServerEither -> sendToClient $ FromServerMess m $ ReqMess msg return reqId @@ -416,39 +442,36 @@ 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+{- | 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 (vfsData vfs) uri of+ 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}+ Nothing -> reverseMap vfs+ !vfs' = vfs{reverseMap = revMap} act = do write pure (Just fn)- in (act, vfs')+ in (act, vfs') -- | Given a text document identifier, annotate it with the latest version. getVersionedTextDoc :: MonadLsp config m => TextDocumentIdentifier -> m VersionedTextDocumentIdentifier@@ -457,20 +480,20 @@ mvf <- getVirtualFile (toNormalizedUri uri) let ver = case mvf of Just (VirtualFile lspver _ _) -> lspver- Nothing -> 0+ 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.++{- | 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 #-} -- ---------------------------------------------------------------------@@ -479,7 +502,6 @@ sendToClient msg = do f <- resSendMessage <$> getLspEnv liftIO $ f msg- {-# INLINE sendToClient #-} -- ---------------------------------------------------------------------@@ -487,33 +509,29 @@ freshLspId :: MonadLsp config m => m Int32 freshLspId = do stateState resLspId $ \cur ->- let !next = cur+1 in (cur, next)-+ 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'.+{- | 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.@@ -524,101 +542,63 @@ 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- => SClientMethod m- -> RegistrationOptions m- -> Handler f m- -> f (Maybe (RegistrationToken m))+{- | 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 =>+ 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+ 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 = L.TRegistration uuid method (Just regOpts)- params = L.RegistrationParams [toUntypedRegistration 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 SMethod_ClientRegisterCapability params $ \_res -> pure ()-- pure (Just (RegistrationToken method regId))- | otherwise = pure Nothing+ where+ -- If the server has already registered statically, don't dynamically register+ -- as per the spec+ go _clientCaps True = pure Nothing+ go clientCaps False+ -- First, check to see if the client supports dynamic registration on this method+ | dynamicRegistrationSupported method clientCaps = do+ uuid <- liftIO $ UUID.toText <$> getStdRandom random+ let registration = L.TRegistration uuid method (Just regOpts)+ params = L.RegistrationParams [toUntypedRegistration registration]+ regId = RegistrationId uuid+ rio <- askUnliftIO+ ~() <- 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" - -- 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 :: L.HasDynamicRegistration a (Maybe Bool) => Maybe a -> Bool- capDyn (Just x) = fromMaybe False $ x ^. L.dynamicRegistration- capDyn Nothing = False+ -- TODO: handle the scenario where this returns an error+ _ <- sendRequest SMethod_ClientRegisterCapability params $ \_res -> pure () - -- | Checks if client capabilities declares that the method supports dynamic registration- dynamicSupported clientCaps = case method of- SMethod_WorkspaceDidChangeConfiguration -> capDyn $ clientCaps ^? L.workspace . _Just . L.didChangeConfiguration . _Just- SMethod_WorkspaceDidChangeWatchedFiles -> capDyn $ clientCaps ^? L.workspace . _Just . L.didChangeWatchedFiles . _Just- SMethod_WorkspaceSymbol -> capDyn $ clientCaps ^? L.workspace . _Just . L.symbol . _Just- SMethod_WorkspaceExecuteCommand -> capDyn $ clientCaps ^? L.workspace . _Just . L.executeCommand . _Just- SMethod_TextDocumentDidOpen -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just- SMethod_TextDocumentDidChange -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just- SMethod_TextDocumentDidClose -> capDyn $ clientCaps ^? L.textDocument . _Just . L.synchronization . _Just- SMethod_TextDocumentCompletion -> capDyn $ clientCaps ^? L.textDocument . _Just . L.completion . _Just- SMethod_TextDocumentHover -> capDyn $ clientCaps ^? L.textDocument . _Just . L.hover . _Just- SMethod_TextDocumentSignatureHelp -> capDyn $ clientCaps ^? L.textDocument . _Just . L.signatureHelp . _Just- SMethod_TextDocumentDeclaration -> capDyn $ clientCaps ^? L.textDocument . _Just . L.declaration . _Just- SMethod_TextDocumentDefinition -> capDyn $ clientCaps ^? L.textDocument . _Just . L.definition . _Just- SMethod_TextDocumentTypeDefinition -> capDyn $ clientCaps ^? L.textDocument . _Just . L.typeDefinition . _Just- SMethod_TextDocumentImplementation -> capDyn $ clientCaps ^? L.textDocument . _Just . L.implementation . _Just- SMethod_TextDocumentReferences -> capDyn $ clientCaps ^? L.textDocument . _Just . L.references . _Just- SMethod_TextDocumentDocumentHighlight -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentHighlight . _Just- SMethod_TextDocumentDocumentSymbol -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentSymbol . _Just- SMethod_TextDocumentCodeAction -> capDyn $ clientCaps ^? L.textDocument . _Just . L.codeAction . _Just- SMethod_TextDocumentCodeLens -> capDyn $ clientCaps ^? L.textDocument . _Just . L.codeLens . _Just- SMethod_TextDocumentDocumentLink -> capDyn $ clientCaps ^? L.textDocument . _Just . L.documentLink . _Just- SMethod_TextDocumentDocumentColor -> capDyn $ clientCaps ^? L.textDocument . _Just . L.colorProvider . _Just- SMethod_TextDocumentColorPresentation -> capDyn $ clientCaps ^? L.textDocument . _Just . L.colorProvider . _Just- SMethod_TextDocumentFormatting -> capDyn $ clientCaps ^? L.textDocument . _Just . L.formatting . _Just- SMethod_TextDocumentRangeFormatting -> capDyn $ clientCaps ^? L.textDocument . _Just . L.rangeFormatting . _Just- SMethod_TextDocumentOnTypeFormatting -> capDyn $ clientCaps ^? L.textDocument . _Just . L.onTypeFormatting . _Just- SMethod_TextDocumentRename -> capDyn $ clientCaps ^? L.textDocument . _Just . L.rename . _Just- SMethod_TextDocumentFoldingRange -> capDyn $ clientCaps ^? L.textDocument . _Just . L.foldingRange . _Just- SMethod_TextDocumentSelectionRange -> capDyn $ clientCaps ^? L.textDocument . _Just . L.selectionRange . _Just- SMethod_TextDocumentPrepareCallHierarchy -> capDyn $ clientCaps ^? L.textDocument . _Just . L.callHierarchy . _Just- --SMethod_TextDocumentSemanticTokens -> capDyn $ clientCaps ^? L.textDocument . _Just . L.semanticTokens . _Just- _ -> False+ pure (Just (RegistrationToken method regId))+ | otherwise = pure Nothing --- | Sends a @client/unregisterCapability@ request and removes the handler--- for that associated registration.+{- | 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+ 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@@ -631,86 +611,93 @@ storeProgress :: MonadLsp config m => ProgressToken -> Async a -> m () storeProgress n a = modifyState (progressCancel . resProgressData) $ Map.insert n (cancelWith a ProgressCancelledException)- {-# INLINE storeProgress #-} deleteProgress :: MonadLsp config m => ProgressToken -> m () deleteProgress n = modifyState (progressCancel . resProgressData) $ Map.delete n- {-# INLINE deleteProgress #-} -- Get a new id for the progress session and make a new one getNewProgressId :: MonadLsp config m => m ProgressToken getNewProgressId = do stateState (progressNextId . resProgressData) $ \cur ->- let !next = cur+1- in (L.ProgressToken $ L.InL cur, next)-+ let !next = cur + 1+ in (L.ProgressToken $ L.InL cur, next) {-# INLINE getNewProgressId #-} withProgressBase :: MonadLsp c m => Bool -> Text -> ProgressCancellable -> ((ProgressAmount -> m ()) -> m a) -> m a withProgressBase indefinite title cancellable f = do- progId <- getNewProgressId let initialPercentage | indefinite = Nothing | otherwise = Just 0 cancellable' = case cancellable of- Cancellable -> True- NotCancellable -> False+ Cancellable -> True+ NotCancellable -> False -- Create progress token -- FIXME : This needs to wait until the request returns before -- continuing!!!- _ <- sendRequest SMethod_WindowWorkDoneProgressCreate- (WorkDoneProgressCreateParams progId) $ \res -> do- case res of- -- An error occurred when the client was setting it up- -- No need to do anything then, as per the spec- Left _err -> pure ()- Right _ -> pure ()+ _ <- sendRequest+ SMethod_WindowWorkDoneProgressCreate+ (WorkDoneProgressCreateParams progId)+ $ \res -> do+ case res of+ -- An error occurred when the client was setting it up+ -- No need to do anything then, as per the spec+ Left _err -> pure ()+ Right _ -> pure () -- Send the begin and done notifications via 'bracket_' so that they are always fired res <- withRunInIO $ \runInBase -> E.bracket_ -- Send begin notification- (runInBase $ sendNotification SMethod_Progress $- ProgressParams progId $ J.toJSON $- WorkDoneProgressBegin L.AString title (Just cancellable') Nothing initialPercentage)-+ ( runInBase $+ sendNotification SMethod_Progress $+ ProgressParams progId $+ J.toJSON $+ WorkDoneProgressBegin L.AString title (Just cancellable') Nothing initialPercentage+ ) -- Send end notification- (runInBase $ sendNotification SMethod_Progress $- ProgressParams progId $ J.toJSON $ (WorkDoneProgressEnd L.AString Nothing)) $ do-- -- Run f asynchronously- aid <- async $ runInBase $ f (updater progId)- runInBase $ storeProgress progId aid- wait aid+ ( runInBase $+ sendNotification SMethod_Progress $+ ProgressParams progId $+ J.toJSON $+ (WorkDoneProgressEnd L.AString Nothing)+ )+ $ do+ -- Run f asynchronously+ aid <- async $ runInBase $ f (updater progId)+ runInBase $ storeProgress progId aid+ wait aid -- Delete the progress cancellation from the map -- If we don't do this then it's easy to leak things as the map contains any IO action. deleteProgress progId return res- where updater progId (ProgressAmount percentage msg) = do- sendNotification SMethod_Progress $ ProgressParams progId $ J.toJSON $- WorkDoneProgressReport L.AString Nothing msg percentage+ where+ updater progId (ProgressAmount percentage msg) = do+ sendNotification SMethod_Progress $+ ProgressParams progId $+ J.toJSON $+ WorkDoneProgressReport L.AString Nothing msg percentage clientSupportsProgress :: L.ClientCapabilities -> Bool clientSupportsProgress caps = fromMaybe False $ caps ^? L.window . _Just . L.workDoneProgress . _Just- {-# INLINE clientSupportsProgress #-} --- | Wrapper for reporting progress to the client during a long running--- task.--- 'withProgress' @title cancellable f@ starts a new progress reporting--- session, and finishes it once f is completed.--- f is provided with an update function that allows it to report on--- the progress during the session.--- If @cancellable@ is 'Cancellable', @f@ will be thrown a--- 'ProgressCancelledException' if the user cancels the action in--- progress.+{- | 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@@ -718,10 +705,11 @@ 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+{- | 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@@ -731,25 +719,31 @@ -- --------------------------------------------------------------------- --- | 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.+{- | 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->+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)+ 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 Text -> m ()+{- | 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@@ -759,33 +753,34 @@ Nothing -> return () Just params -> do sendToClient $ L.fromServerNot $ L.TNotificationMessage "2.0" L.SMethod_TextDocumentPublishDiagnostics params- in (act,newDiags)+ 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.+{- | 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+ where+ cs' :: Maybe (Map.Map Uri [TextEdit])+ cs' = (fmap . fmap) sortTextEdits cs - dcs' :: Maybe [L.DocumentChange]- dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs+ dcs' :: Maybe [L.DocumentChange]+ dcs' = (fmap . fmap) sortOnlyTextDocumentEdits dcs - sortTextEdits :: [L.TextEdit] -> [L.TextEdit]- sortTextEdits edits = L.sortOn (Down . (^. L.range)) edits+ 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+ 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+ editRange :: L.TextEdit L.|? L.AnnotatedTextEdit -> L.Range+ editRange (L.InR e) = e ^. L.range+ editRange (L.InL e) = e ^. L.range -------------------------------------------------------------------------------- -- CONFIG@@ -796,7 +791,7 @@ tryChangeConfig logger newConfigObject = do parseCfg <- LspT $ asks resParseConfig res <- stateState resConfig $ \oldConfig -> case parseCfg oldConfig newConfigObject of- Left err -> (Left err, oldConfig)+ Left err -> (Left err, oldConfig) Right newConfig -> (Right newConfig, newConfig) case res of Left err -> do@@ -806,23 +801,23 @@ 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.+{- | 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+ 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 {- Note [LSP configuration] LSP configuration is a huge mess.
src/Language/LSP/Server/Processing.hs view
@@ -1,74 +1,82 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeInType #-}--{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}--- there's just so much!-{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeInType #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-}+-- there's just so much!+{-# OPTIONS_GHC -Wno-name-shadowing #-}+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} module Language.LSP.Server.Processing where -import Colog.Core (LogAction (..),- Severity (..),- WithSeverity (..),- cmap, (<&))+import Colog.Core (+ LogAction (..),+ Severity (..),+ WithSeverity (..),+ cmap,+ (<&),+ ) -import Control.Concurrent.STM-import qualified Control.Exception as E-import Control.Lens hiding (Empty)-import Control.Monad-import Control.Monad.Except ()-import Control.Monad.IO.Class-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Trans.Except-import Control.Monad.Writer.Strict-import Data.Aeson hiding (Error, Null,- Options)-import Data.Aeson.Lens ()-import Data.Aeson.Types hiding (Error, Null,- Options)-import qualified Data.ByteString.Lazy as BSL-import Data.Foldable (traverse_)-import qualified Data.Functor.Product as P-import Data.IxMap-import Data.List-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.Map.Strict as Map-import Data.Maybe-import Data.Monoid-import Data.Row-import Data.String (fromString)-import qualified Data.Text as T-import qualified Data.Text.Lazy.Encoding as TL-import Data.Text.Prettyprint.Doc-import qualified Language.LSP.Protocol.Lens as L-import Language.LSP.Protocol.Message-import Language.LSP.Protocol.Types-import Language.LSP.Protocol.Utils.SMethodMap (SMethodMap)-import qualified Language.LSP.Protocol.Utils.SMethodMap as SMethodMap-import Language.LSP.Server.Core-import Language.LSP.VFS as VFS-import System.Exit+import Control.Concurrent.STM+import Control.Exception qualified as E+import Control.Lens hiding (Empty)+import Control.Monad+import Control.Monad.Except ()+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Except+import Control.Monad.Writer.Strict+import Data.Aeson hiding (+ Error,+ Null,+ Options,+ )+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.Maybe+import Data.Monoid+import Data.Row+import Data.String (fromString)+import Data.Text qualified as T+import Data.Text.Lazy.Encoding qualified as TL+import Data.Text.Prettyprint.Doc+import Language.LSP.Protocol.Lens qualified as L+import Language.LSP.Protocol.Message+import Language.LSP.Protocol.Types+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 System.Exit -data LspProcessingLog =- VfsLog VfsLog+data LspProcessingLog+ = VfsLog VfsLog | LspCore LspCoreLog | MessageProcessingError BSL.ByteString String- | forall m . MissingHandler Bool (SClientMethod m)+ | forall m. MissingHandler Bool (SClientMethod m) | ProgressCancel ProgressToken | Exiting @@ -78,8 +86,8 @@ 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)@@ -92,31 +100,31 @@ processMessage logger jsonStr = do pendingResponsesVar <- LspT $ asks $ resPendingResponses . resState 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 ^. 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+ 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 ^. 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- :: LogAction IO (WithSeverity LspProcessingLog)- -> ServerDefinition config- -> VFS- -> (FromServerMessage -> IO ())- -> TMessage Method_Initialize- -> IO (Maybe (LanguageContextEnv config))+initializeRequestHandler ::+ LogAction IO (WithSeverity LspProcessingLog) ->+ ServerDefinition config ->+ VFS ->+ (FromServerMessage -> IO ()) ->+ TMessage Method_Initialize ->+ IO (Maybe (LanguageContextEnv config)) initializeRequestHandler logger ServerDefinition{..} vfs sendFunc req = do let sendResp = sendFunc . FromServerRsp SMethod_Initialize handleErr (Left err) = do@@ -124,41 +132,47 @@ pure Nothing handleErr (Right a) = pure $ Just a flip E.catch (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 ]+ rootDir =+ getFirst $+ foldMap+ First+ [ p ^? L.rootUri . _L >>= uriToFilePath+ , p ^? L.rootPath . _Just . _L <&> T.unpack+ ] clientCaps = (p ^. L.capabilities) let initialWfs = case p ^. L.workspaceFolders of Just (InL xs) -> xs- _ -> []+ _ -> [] -- See Note [LSP configuration] configObject = lookForConfigSection configSection <$> (p ^. L.initializationOptions) initialConfig <- case configObject of Just o -> case parseConfig defaultConfig o of- Right newConfig -> pure newConfig- Left err -> do- -- Warn not error here, since initializationOptions is pretty unspecified- liftIO $ logger <& (LspCore $ ConfigurationParseError o err) `WithSeverity` Warning- pure defaultConfig+ 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 Nothing -> 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 pure LanguageContextState{..} -- Call the 'duringInitialization' callback to let the server kick stuff up@@ -171,195 +185,248 @@ let serverCaps = inferServerCapabilities clientCaps options handlers liftIO $ sendResp $ makeResponseMessage (req ^. L.id) (InitializeResult serverCaps (optServerInfo options)) pure env- where- makeResponseMessage rid result = TResponseMessage "2.0" (Just rid) (Right result)- makeResponseError origId err = TResponseMessage "2.0" (Just origId) (Left err)-- initializeErrorHandler :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a)- initializeErrorHandler sendResp e = do- sendResp $ ResponseError (InR ErrorCodes_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 :: (ResponseError -> IO ()) -> E.SomeException -> IO (Maybe a)+ initializeErrorHandler sendResp e = do+ sendResp $ ResponseError (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 = ServerCapabilities- { _textDocumentSync = sync- , _hoverProvider = supportedBool SMethod_TextDocumentHover- , _completionProvider = completionProvider- , _declarationProvider = supportedBool SMethod_TextDocumentDeclaration- , _signatureHelpProvider = signatureHelpProvider- , _definitionProvider = supportedBool SMethod_TextDocumentDefinition- , _typeDefinitionProvider = supportedBool SMethod_TextDocumentTypeDefinition- , _implementationProvider = supportedBool SMethod_TextDocumentImplementation- , _referencesProvider = supportedBool SMethod_TextDocumentReferences- , _documentHighlightProvider = supportedBool SMethod_TextDocumentDocumentHighlight- , _documentSymbolProvider = supportedBool SMethod_TextDocumentDocumentSymbol- , _codeActionProvider = codeActionProvider- , _codeLensProvider = supported' SMethod_TextDocumentCodeLens $ CodeLensOptions- (Just False)- (supported SMethod_CodeLensResolve)- , _documentFormattingProvider = supportedBool SMethod_TextDocumentFormatting- , _documentRangeFormattingProvider = supportedBool SMethod_TextDocumentRangeFormatting+ { _textDocumentSync = sync+ , _hoverProvider = supportedBool SMethod_TextDocumentHover+ , _completionProvider = completionProvider+ , _inlayHintProvider = inlayProvider+ , _declarationProvider = supportedBool SMethod_TextDocumentDeclaration+ , _signatureHelpProvider = signatureHelpProvider+ , _definitionProvider = supportedBool SMethod_TextDocumentDefinition+ , _typeDefinitionProvider = supportedBool SMethod_TextDocumentTypeDefinition+ , _implementationProvider = supportedBool SMethod_TextDocumentImplementation+ , _referencesProvider = supportedBool SMethod_TextDocumentReferences+ , _documentHighlightProvider = supportedBool SMethod_TextDocumentDocumentHighlight+ , _documentSymbolProvider = supportedBool SMethod_TextDocumentDocumentSymbol+ , _codeActionProvider = codeActionProvider+ , _codeLensProvider =+ supported' SMethod_TextDocumentCodeLens $+ CodeLensOptions+ (Just False)+ (supported SMethod_CodeLensResolve)+ , _documentFormattingProvider = supportedBool SMethod_TextDocumentFormatting+ , _documentRangeFormattingProvider = supportedBool SMethod_TextDocumentRangeFormatting , _documentOnTypeFormattingProvider = documentOnTypeFormattingProvider- , _renameProvider = renameProvider- , _documentLinkProvider = supported' SMethod_TextDocumentDocumentLink $ DocumentLinkOptions- (Just False)- (supported SMethod_DocumentLinkResolve)- , _colorProvider = supportedBool SMethod_TextDocumentDocumentColor- , _foldingRangeProvider = supportedBool SMethod_TextDocumentFoldingRange- , _executeCommandProvider = executeCommandProvider- , _selectionRangeProvider = supportedBool SMethod_TextDocumentSelectionRange- , _callHierarchyProvider = supportedBool SMethod_TextDocumentPrepareCallHierarchy- , _semanticTokensProvider = semanticTokensProvider- , _workspaceSymbolProvider = supportedBool SMethod_WorkspaceSymbol- , _workspace = Just workspace- -- TODO: Add something for experimental- , _experimental = Nothing :: Maybe Value- -- TODO- , _positionEncoding = Nothing- , _notebookDocumentSync = Nothing- , _linkedEditingRangeProvider = Nothing- , _monikerProvider = Nothing- , _typeHierarchyProvider = Nothing- , _inlineValueProvider = Nothing- , _inlayHintProvider = Nothing- , _diagnosticProvider = Nothing+ , _renameProvider = renameProvider+ , _documentLinkProvider =+ supported' SMethod_TextDocumentDocumentLink $+ DocumentLinkOptions+ (Just False)+ (supported SMethod_DocumentLinkResolve)+ , _colorProvider = supportedBool SMethod_TextDocumentDocumentColor+ , _foldingRangeProvider = supportedBool SMethod_TextDocumentFoldingRange+ , _executeCommandProvider = executeCommandProvider+ , _selectionRangeProvider = supportedBool SMethod_TextDocumentSelectionRange+ , _callHierarchyProvider = supportedBool SMethod_TextDocumentPrepareCallHierarchy+ , _semanticTokensProvider = semanticTokensProvider+ , _workspaceSymbolProvider = supportedBool SMethod_WorkspaceSymbol+ , _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{_workDoneProgress = Nothing}+ , _monikerProvider =+ supported' SMethod_TextDocumentMoniker $+ InR $+ InL $+ MonikerOptions{_workDoneProgress = Nothing}+ , _typeHierarchyProvider =+ supported' SMethod_TextDocumentPrepareTypeHierarchy $+ InR $+ InL $+ TypeHierarchyOptions{_workDoneProgress = Nothing}+ , _inlineValueProvider =+ supported' SMethod_TextDocumentInlineValue $+ InR $+ InL $+ InlineValueOptions{_workDoneProgress = Nothing}+ , _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+ -- \| For when we just return a simple @true@/@false@ to indicate if we+ -- support the capability+ supportedBool = Just . InL . supported_b - 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 SMethod_TextDocumentCompletion = Just $- CompletionOptions {- _triggerCharacters=map T.singleton <$> optCompletionTriggerCharacters o- , _allCommitCharacters=map T.singleton <$> optCompletionAllCommitCharacters o- , _resolveProvider=supported SMethod_CompletionItemResolve- , _completionItem=Nothing- , _workDoneProgress=Nothing+ completionProvider+ | supported_b SMethod_TextDocumentCompletion =+ Just $+ CompletionOptions+ { _triggerCharacters = map T.singleton <$> optCompletionTriggerCharacters o+ , _allCommitCharacters = map T.singleton <$> optCompletionAllCommitCharacters o+ , _resolveProvider = supported SMethod_CompletionItemResolve+ , _completionItem = Nothing+ , _workDoneProgress = Nothing }- | otherwise = Nothing+ | otherwise = Nothing - clientSupportsCodeActionKinds = isJust $+ inlayProvider+ | supported_b SMethod_TextDocumentInlayHint =+ Just $+ InR $+ InL+ InlayHintOptions+ { _workDoneProgress = Nothing+ , _resolveProvider = supported SMethod_InlayHintResolve+ }+ | otherwise = Nothing++ clientSupportsCodeActionKinds =+ isJust $ clientCaps ^? L.textDocument . _Just . L.codeAction . _Just . L.codeActionLiteralSupport . _Just - codeActionProvider- | supported_b SMethod_TextDocumentCodeAction = Just $ InR $- CodeActionOptions {- _workDoneProgress = Nothing- , _codeActionKinds = codeActionKinds (optCodeActionKinds o)- , _resolveProvider = supported SMethod_CodeActionResolve- }- | otherwise = Just (InL False)+ codeActionProvider+ | supported_b SMethod_TextDocumentCodeAction =+ Just $+ InR $+ CodeActionOptions+ { _workDoneProgress = Nothing+ , _codeActionKinds = codeActionKinds (optCodeActionKinds o)+ , _resolveProvider = supported SMethod_CodeActionResolve+ }+ | otherwise = Just (InL False) - codeActionKinds (Just ks)- | clientSupportsCodeActionKinds = Just ks- codeActionKinds _ = Nothing+ codeActionKinds (Just ks)+ | clientSupportsCodeActionKinds = Just ks+ codeActionKinds _ = Nothing - signatureHelpProvider- | supported_b SMethod_TextDocumentSignatureHelp = Just $+ signatureHelpProvider+ | supported_b SMethod_TextDocumentSignatureHelp =+ Just $ SignatureHelpOptions Nothing (map T.singleton <$> optSignatureHelpTriggerCharacters o) (map T.singleton <$> optSignatureHelpRetriggerCharacters o)- | otherwise = Nothing+ | otherwise = Nothing - documentOnTypeFormattingProvider- | supported_b SMethod_TextDocumentOnTypeFormatting- , Just (first :| rest) <- optDocumentOnTypeFormattingTriggerCharacters 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 SMethod_TextDocumentOnTypeFormatting- , Nothing <- optDocumentOnTypeFormattingTriggerCharacters 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 SMethod_WorkspaceExecuteCommand- , Just cmds <- optExecuteCommandCommands o = Just (ExecuteCommandOptions Nothing cmds)- | supported_b SMethod_WorkspaceExecuteCommand- , Nothing <- optExecuteCommandCommands o =- error "executeCommandCommands needs to be set if a executeCommandHandler is set"- | otherwise = Nothing+ executeCommandProvider+ | supported_b SMethod_WorkspaceExecuteCommand+ , Just cmds <- optExecuteCommandCommands o =+ Just (ExecuteCommandOptions Nothing cmds)+ | supported_b SMethod_WorkspaceExecuteCommand+ , Nothing <- optExecuteCommandCommands o =+ error "executeCommandCommands needs to be set if a executeCommandHandler is set"+ | otherwise = Nothing - clientSupportsPrepareRename = fromMaybe False $+ clientSupportsPrepareRename =+ fromMaybe False $ clientCaps ^? L.textDocument . _Just . L.rename . _Just . L.prepareSupport . _Just - renameProvider- | clientSupportsPrepareRename- , supported_b SMethod_TextDocumentRename- , supported_b SMethod_TextDocumentPrepareRename = Just $- InR . RenameOptions Nothing . Just $ True- | supported_b SMethod_TextDocumentRename = Just (InL True)- | otherwise = Just (InL False)+ renameProvider+ | clientSupportsPrepareRename+ , supported_b SMethod_TextDocumentRename+ , supported_b SMethod_TextDocumentPrepareRename =+ Just $+ InR . RenameOptions Nothing . Just $+ True+ | supported_b SMethod_TextDocumentRename = Just (InL True)+ | otherwise = Just (InL False) - -- Always provide the default legend- -- TODO: allow user-provided legend via 'Options', or at least user-provided types- semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider- semanticTokenRangeProvider- | supported_b SMethod_TextDocumentSemanticTokensRange = Just $ InL True- | otherwise = Nothing- semanticTokenFullProvider- | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ #delta .== supported SMethod_TextDocumentSemanticTokensFullDelta- | otherwise = Nothing+ -- Always provide the default legend+ -- TODO: allow user-provided legend via 'Options', or at least user-provided types+ semanticTokensProvider = Just $ InL $ SemanticTokensOptions Nothing defaultSemanticTokensLegend semanticTokenRangeProvider semanticTokenFullProvider+ semanticTokenRangeProvider+ | supported_b SMethod_TextDocumentSemanticTokensRange = Just $ InL True+ | otherwise = Nothing+ semanticTokenFullProvider+ | supported_b SMethod_TextDocumentSemanticTokensFull = Just $ InR $ #delta .== supported SMethod_TextDocumentSemanticTokensFullDelta+ | otherwise = Nothing - sync = case optTextDocumentSync o of- Just x -> Just (InL x)- Nothing -> Nothing+ sync = case optTextDocumentSync o of+ Just x -> Just (InL x)+ Nothing -> Nothing - workspace = #workspaceFolders .== workspaceFolder .+ #fileOperations .== Nothing- workspaceFolder = supported' SMethod_WorkspaceDidChangeWorkspaceFolders $- -- sign up to receive notifications- WorkspaceFoldersServerCapabilities (Just True) (Just (InR True))+ workspace = #workspaceFolders .== workspaceFolder .+ #fileOperations .== Nothing+ workspaceFolder =+ supported' SMethod_WorkspaceDidChangeWorkspaceFolders $+ -- sign up to receive notifications+ WorkspaceFoldersServerCapabilities (Just True) (Just (InR True)) --- | Invokes the registered dynamic or static handlers for the given message and--- method, as well as doing some bookkeeping.+ diagnosticProvider =+ supported' SMethod_TextDocumentDiagnostic $+ InL $+ DiagnosticOptions+ { _workDoneProgress = Nothing+ , _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 :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> SClientMethod meth -> TClientMessage meth -> m () handle logger m msg = case m of SMethod_WorkspaceDidChangeWorkspaceFolders -> handle' logger (Just updateWorkspaceFolders) m msg- SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg+ SMethod_WorkspaceDidChangeConfiguration -> handle' logger (Just $ handleDidChangeConfiguration logger) m msg -- See Note [LSP configuration]- SMethod_Initialized -> handle' logger (Just $ \_ -> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg- SMethod_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+ SMethod_Initialized -> handle' logger (Just $ \_ -> requestConfigUpdate (cmap (fmap LspCore) logger)) m msg+ 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 ClientToServer t) config- . (m ~ LspM config)- => LogAction m (WithSeverity LspProcessingLog)- -> Maybe (TClientMessage meth -> m ())- -- ^ An action to be run before invoking the handler, used for- -- bookkeeping stuff like the vfs etc.- -> SClientMethod meth- -> TClientMessage 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 @@ -370,10 +437,16 @@ let Handlers{reqHandlers, notHandlers} = resHandlers env let mkRspCb :: TRequestMessage (m1 :: Method ClientToServer Request) -> Either ResponseError (MessageResult m1) -> IO ()- mkRspCb req (Left err) = runLspT env $ sendToClient $- FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) (Left err)- mkRspCb req (Right rsp) = runLspT env $ sendToClient $- FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) (Right rsp)+ mkRspCb req (Left err) =+ runLspT env $+ sendToClient $+ FromServerRsp (req ^. L.method) $+ TResponseMessage "2.0" (Just (req ^. L.id)) (Left err)+ mkRspCb req (Right rsp) =+ runLspT env $+ sendToClient $+ FromServerRsp (req ^. L.method) $+ TResponseMessage "2.0" (Just (req ^. L.id)) (Right rsp) case splitClientMethod m of IsClientNot -> case pickHandler dynNotHandlers notHandlers of@@ -382,7 +455,6 @@ | SMethod_Exit <- m -> exitNotificationHandler logger msg | otherwise -> do reportMissingHandler- IsClientReq -> case pickHandler dynReqHandlers reqHandlers of Just h -> liftIO $ h msg (mkRspCb msg) Nothing@@ -391,11 +463,11 @@ let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing sendToClient $- FromServerRsp (msg ^. L.method) $ TResponseMessage "2.0" (Just (msg ^. L.id)) (Left err)-+ FromServerRsp (msg ^. L.method) $+ TResponseMessage "2.0" (Just (msg ^. L.id)) (Left err) IsClientEither -> case msg of NotMess noti -> case pickHandler dynNotHandlers notHandlers of- Just h -> liftIO $ h noti+ Just h -> liftIO $ h noti Nothing -> reportMissingHandler ReqMess req -> case pickHandler dynReqHandlers reqHandlers of Just h -> liftIO $ h req (mkRspCb req)@@ -403,23 +475,24 @@ let errorMsg = T.pack $ unwords ["lsp:no handler for: ", show m] err = ResponseError (InR ErrorCodes_MethodNotFound) errorMsg Nothing sendToClient $- FromServerRsp (req ^. L.method) $ TResponseMessage "2.0" (Just (req ^. L.id)) (Left err)- 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+ FromServerRsp (req ^. L.method) $+ TResponseMessage "2.0" (Just (req ^. L.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 - -- '$/' 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 = isOptionalMethod (SomeMethod m)- in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error+ -- '$/' 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 = isOptionalMethod (SomeMethod m)+ in logger <& MissingHandler optional m `WithSeverity` if optional then Warning else Error progressCancelHandler :: (m ~ LspM config) => LogAction m (WithSeverity LspProcessingLog) -> TMessage Method_WindowWorkDoneProgressCancel -> m () progressCancelHandler logger (TNotificationMessage _ _ (WorkDoneProgressCancelParams tid)) = do@@ -440,10 +513,11 @@ shutdownRequestHandler _req k = do k $ Right Null --- | 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]+{- | 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@@ -464,12 +538,13 @@ 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 ::+ 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@@ -479,11 +554,11 @@ -- 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 :: TMessage Method_WorkspaceDidChangeWorkspaceFolders -> LspM config ()
src/Language/LSP/VFS.hs view
@@ -1,120 +1,121 @@ {-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeInType #-}- {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-+{-# LANGUAGE ViewPatterns #-} -- So we can keep using the old prettyprinter modules (which have a better -- compatibility range) for now. {-# OPTIONS_GHC -Wno-deprecations #-} -{-|+{- | Handles the "Language.LSP.Types.TextDocumentDidChange" \/ "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 (..),+ lsp_version,+ file_version,+ file_text,+ virtualFileText,+ virtualFileVersion,+ 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,+ PosPrefixInfo (..),+ getCompletionPrefix, -- * 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.Row-import Data.Ord-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.Protocol.Types as J-import qualified Language.LSP.Protocol.Lens as J-import qualified Language.LSP.Protocol.Message 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.Char (isAlphaNum, isUpper) import Data.Foldable (traverse_)+import Data.Hashable+import Data.Int (Int32)+import Data.List+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Ord+import Data.Row+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as T+import Data.Text.Prettyprint.Doc hiding (line)+import Data.Text.Rope qualified as URope+import Data.Text.Utf16.Rope (Rope)+import Data.Text.Utf16.Rope qualified as Rope+import Language.LSP.Protocol.Lens qualified as J+import Language.LSP.Protocol.Message qualified as J+import Language.LSP.Protocol.Types qualified as J+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+ }+ 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+data VFS = VFS+ { _vfsMap :: !(Map.Map J.NormalizedUri VirtualFile)+ }+ deriving (Show) -data VfsLog =- SplitInsideCodePoint Rope.Position Rope+data VfsLog+ = SplitInsideCodePoint Rope.Position Rope | URINotFound J.NormalizedUri | Opening J.NormalizedUri | Closing J.NormalizedUri@@ -147,8 +148,8 @@ --- -initVFS :: (VFS -> IO r) -> IO r-initVFS k = withSystemTempDirectory "haskell-lsp" $ \temp_dir -> k (VFS mempty temp_dir)+emptyVFS :: VFS+emptyVFS = VFS mempty -- --------------------------------------------------------------------- @@ -180,51 +181,52 @@ applyCreateFile :: (MonadState VFS m) => J.CreateFile -> m () applyCreateFile (J.CreateFile _ann _kind (J.toNormalizedUri -> uri) options) =- 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`+ 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` applyRenameFile :: (MonadState VFS m) => J.RenameFile -> m () 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 _ann _kind (J.toNormalizedUri -> uri) options) = do@@ -236,8 +238,9 @@ 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 ()@@ -247,28 +250,27 @@ let sortedEdits = sortOn (Down . editRange) edits changeEvents = map editToChangeEvent sortedEdits -- TODO: is this right?- vid' = J.VersionedTextDocumentIdentifier (vid ^. J.uri) (case vid ^. J.version of {J.InL v -> v; J.InR _ -> 0})+ 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 $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText- editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText+ editToChangeEvent :: J.TextEdit J.|? J.AnnotatedTextEdit -> J.TextDocumentContentChangeEvent+ editToChangeEvent (J.InR e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText+ editToChangeEvent (J.InL e) = J.TextDocumentContentChangeEvent $ J.InL $ #range .== e ^. J.range .+ #rangeLength .== Nothing .+ #text .== e ^. J.newText 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.TMessage 'J.Method_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@@ -277,20 +279,19 @@ Nothing -> case mChanges of Just cs -> applyDocumentChanges $ map J.InL $ Map.foldlWithKey' changeToTextDocumentEdit [] cs Nothing -> pure ()-- where- changeToTextDocumentEdit acc uri edits =- acc ++ [J.TextDocumentEdit (J.OptionalVersionedTextDocumentIdentifier uri (J.InL 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 -> Maybe J.Int32- project (J.InL textDocumentEdit) = case textDocumentEdit ^. J.textDocument . J.version of- J.InL v -> Just v- _ -> Nothing- 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@@ -303,28 +304,28 @@ 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+ 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) -- --------------------------------------------------------------------- @@ -336,52 +337,60 @@ -- --------------------------------------------------------------------- --- | 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 logger str (J.TextDocumentContentChangeEvent (J.InL e)) | J.Range (J.Position sl sc) (J.Position fl fc) <- e .! #range, txt <- e .! #text- = changeChars logger str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt-applyChange _ _ (J.TextDocumentContentChangeEvent (J.InR e))- = pure $ Rope.fromText $ e .! #text+applyChange logger str (J.TextDocumentContentChangeEvent (J.InL e))+ | J.Range (J.Position sl sc) (J.Position fl fc) <- e .! #range+ , txt <- e .! #text =+ changeChars logger str (Rope.Position (fromIntegral sl) (fromIntegral sc)) (Rope.Position (fromIntegral fl) (fromIntegral fc)) txt+applyChange _ _ (J.TextDocumentContentChangeEvent (J.InR e)) =+ pure $ Rope.fromText $ e .! #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.+{- | 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 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.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] -- --------------------------------------------------------------------- --- | 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@@ -400,8 +409,9 @@ line. Which is okay-ish, so long as we don't have very long lines. -} --- | 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@@ -412,8 +422,9 @@ (prefix, _) = Rope.splitAtLine 1 suffix pure prefix --- | Translate a code-point offset into a code-unit offset.--- Linear in the length of the rope.+{- | 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@@ -422,11 +433,12 @@ 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*+ -- Get the length of the prefix in *code units* pure $ Rope.length utf16Prefix --- | Translate a UTF-16 code-unit offset into a code-point offset.--- Linear in the length of the rope.+{- | 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@@ -435,15 +447,16 @@ (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*+ -- Get the length of the prefix in *code points* pure $ URope.length utfPrefix --- | Given a virtual file, translate a 'CodePointPosition' in that file into a 'J.Position' in that file.------ Will return 'Nothing' if the requested position is out of bounds of the document.------ 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 '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.+-} codePointPositionToPosition :: VirtualFile -> CodePointPosition -> Maybe J.Position codePointPositionToPosition vFile (CodePointPosition l cpc) = do -- See Note [Converting between code points and code units]@@ -455,22 +468,24 @@ 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.------ 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.+{- | 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.+-} 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 -- See Note [Converting between code points and code units]@@ -480,12 +495,13 @@ 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.------ 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.+{- | 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.+-} rangeToCodePointRange :: VirtualFile -> J.Range -> Maybe CodePointRange rangeToCodePointRange vFile (J.Range b e) = CodePointRange <$> positionToCodePointPosition vFile b <*> positionToCodePointPosition vFile e@@ -493,55 +509,61 @@ -- --------------------------------------------------------------------- -- 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-+ -- ^ 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"-+ -- ^ 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"+ -- ^ 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)+ -- ^ 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+ 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 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+ 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+ 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.Protocol.Types as LSP+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) #-} -- --------------------------------------------------------------------- @@ -34,7 +34,7 @@ let rng = LSP.Range (LSP.Position 0 1) (LSP.Position 3 0) loc = LSP.Location (LSP.Uri "file") rng- in+ in LSP.Diagnostic rng Nothing Nothing Nothing ms str Nothing (Just [LSP.DiagnosticRelatedInformation loc str]) Nothing mkDiagnostic2 :: Maybe Text -> Text -> LSP.Diagnostic@@ -42,7 +42,8 @@ let 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+ in+ LSP.Diagnostic rng Nothing Nothing Nothing ms str Nothing (Just [LSP.DiagnosticRelatedInformation loc str]) Nothing -- --------------------------------------------------------------------- @@ -56,9 +57,9 @@ , mkDiagnostic (Just "hlint") "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.toSortedList diags) ] )+ (updateDiagnostics HM.empty uri Nothing (partitionBySource diags))+ `shouldBe` HM.fromList+ [ (uri, StoreItem Nothing $ Map.fromList [(Just "hlint", SL.toSortedList diags)]) ] -- ---------------------------------@@ -70,12 +71,16 @@ , 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"))- ])+ (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"))+ ]+ ) ] -- ---------------------------------@@ -87,15 +92,19 @@ , 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"))- ])+ (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@@ -109,9 +118,9 @@ ] 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)]) ] -- ---------------------------------@@ -127,12 +136,16 @@ ] 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"))+ ]+ ) ] -- ---------------------------------@@ -145,16 +158,19 @@ ] 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@@ -168,9 +184,9 @@ ] 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)]) ] -- ---------------------------------@@ -186,17 +202,20 @@ ] 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 =@@ -205,65 +224,75 @@ ] uri = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)- getDiagnosticParamsFor 10 ds uri `shouldBe`- Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1) (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 = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)- getDiagnosticParamsFor 2 ds uri `shouldBe`- Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1)- [- 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 (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1)- [- 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 = LSP.toNormalizedUri $ LSP.Uri "uri" let ds = updateDiagnostics HM.empty uri (Just 1) (partitionBySource diags)- getDiagnosticParamsFor 100 ds uri `shouldBe`- Just (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1)- [- mkDiagnostic (Just "ghcmod") "d"- , mkDiagnostic (Just "hlint") "c"+ 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 (LSP.PublishDiagnosticsParams (LSP.fromNormalizedUri uri) (Just 1)- [- mkDiagnostic (Just "ghcmod") "d"+ 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,16 +1,17 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+ module VspSpec where -import Data.Row-import Data.String-import qualified Data.Text.Utf16.Rope as Rope-import Language.LSP.VFS-import qualified Language.LSP.Protocol.Types as J-import qualified Data.Text as T+import Data.Row+import Data.String+import Data.Text qualified as T+import Data.Text.Utf16.Rope 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 -- --------------------------------------------------------------------- @@ -50,27 +51,28 @@ it "handles vscode style redos" $ do let orig = "" changes =- [- mkChangeEvent (J.mkRange 0 1 0 1) "a"+ [ 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"- ]+ 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+ Rope.lines <$> new+ `shouldBe` Identity [ "abcdg" , "module Foo where" , "-oo"@@ -82,14 +84,16 @@ it "deletes one line" $ do -- based on vscode log let- orig = unlines- [ "abcdg"- , "module Foo where"- , "-- fooo"- , "foo :: Int"- ]+ 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+ Rope.lines <$> new+ `shouldBe` Identity [ "abcdg" , "module Foo where" , "foo :: Int"@@ -100,31 +104,35 @@ it "deletes two lines" $ do -- based on vscode log let- orig = unlines- [ "module Foo where"- , "-- fooo"- , "foo :: Int"- , "foo = bb"- ]+ 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+ 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"- ]+ 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+ Rope.lines <$> new+ `shouldBe` Identity [ "abcdg" , "module Foo where" , "-- fooo"@@ -136,38 +144,42 @@ it "adds two lines" $ do -- based on vscode log let- orig = unlines- [ "module Foo where"- , "foo = bb"- ]+ 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+ 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\""- ]+ 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) $ mkChangeEvent (J.mkRange 7 0 7 8) "baz ="- Rope.lines <$> new `shouldBe` Identity+ Rope.lines <$> new+ `shouldBe` Identity [ "module Foo where" , "-- fooo" , "foo :: Int"@@ -180,54 +192,58 @@ ] it "indexes using utf-16 code units" $ do let- orig = unlines- [ "a𐐀b"- , "a𐐀b"- ]+ orig =+ unlines+ [ "a𐐀b"+ , "a𐐀b"+ ] new = applyChange mempty (fromString orig) $ mkChangeEvent (J.mkRange 1 0 1 3) "𐐀𐐀"- Rope.lines <$> new `shouldBe` Identity+ 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"- ]+ orig =+ unlines+ [ "a𐐀b"+ , "a𐐀b"+ ] vfile = VirtualFile 0 0 (fromString orig) positionToCodePointPosition vfile (J.Position 1 0) `shouldBe` Just (CodePointPosition 1 0)@@ -245,10 +261,11 @@ it "converts code points to code units" $ do let- orig = unlines- [ "a𐐀b"- , "a𐐀b"- ]+ orig =+ unlines+ [ "a𐐀b"+ , "a𐐀b"+ ] vfile = VirtualFile 0 0 (fromString orig) codePointPositionToPosition vfile (CodePointPosition 1 0) `shouldBe` Just (J.Position 1 0)@@ -266,10 +283,11 @@ it "getCompletionPrefix" $ do let- orig = T.unlines- [ "{-# ings #-}"- , "import Data.List"- ]+ orig =+ T.unlines+ [ "{-# ings #-}"+ , "import Data.List"+ ] pp4 <- getCompletionPrefix (J.Position 0 4) (vfsFromText orig) pp4 `shouldBe` Just (PosPrefixInfo "{-# ings #-}" "" "" (J.Position 0 4))